tern coverage - 95.80%

Files
Source

#' Occurrence Table Pruning
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Family of constructor and condition functions to flexibly prune occurrence tables.
#' The condition functions always return whether the row result is higher than the threshold.
#' Since they are of class [CombinationFunction()] they can be logically combined with other condition
#' functions.
#'
#' @note Since most table specifications are worded positively, we name our constructor and condition
#'   functions positively, too. However, note that the result of [keep_rows()] says what
#'   should be pruned though, to conform with the [rtables::prune_table()] interface.
#'
#' @name prune_occurrences
#' @examples
#' \dontrun{
#' tab <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_rows_by("RACE") %>%
#'   split_rows_by("STRATA1") %>%
#'   summarize_row_groups() %>%
#'   summarize_vars("COUNTRY", .stats = "count_fraction") %>%
#'   build_table(DM)
#' }
#'
NULL

#' @describeIn prune_occurrences constructor for creating pruning functions based on
#'   a row condition function. This removes all analysis rows (`TableRow`) that should be
#'   pruned, i.e., don't fulfill the row condition. It removes the sub tree if there are no
#'   children left.
#' @param row_condition (`CombinationFunction`)\cr condition function which works on individual
#'   analysis rows and flags whether these should be kept in the pruned table.
#' @return [keep_rows()] returns a pruning function that can be used with [rtables::prune_table()]
#'   on `[rtables::TableTree()]` objects.
#' @export
#'
#' @examples
#' \dontrun{
#' # `keep_rows`
#' is_non_empty <- !CombinationFunction(all_zero_or_na)
#' prune_table(tab, keep_rows(is_non_empty))
#' }
keep_rows <- function(row_condition) {
  checkmate::assert_function(row_condition)
  function(table_tree) {
    if (inherits(table_tree, "TableRow")) {
      return(!row_condition(table_tree))
    }
    children <- tree_children(table_tree)
    identical(length(children), 0L)
  }
}

#' @describeIn prune_occurrences constructor for creating pruning functions based on
#'   a condition for the (first) content row in leaf tables. This removes all leaf tables where
#'   the first content row does not fulfill the condition. It does not check individual rows.
#'   It then proceeds recursively by removing the sub tree if there are no children left.
#' @param content_row_condition (`CombinationFunction`)\cr condition function which works on individual
#'   first content rows of leaf tables and flags whether these leaf tables should be kept in the pruned table.
#' @return [keep_content_rows()] also returns a pruning function, the difference is that it
#'   checks the condition on the first content row of leaf tables in the table.
#'
#' @examples
#' # `keep_content_rows`
#' # Internal function - has_count_in_cols
#' \dontrun{
#' more_than_twenty <- has_count_in_cols(atleast = 20L, col_names = names(tab))
#' prune_table(tab, keep_content_rows(more_than_twenty))
#' }
#'
#' @export
keep_content_rows <- function(content_row_condition) {
  checkmate::assert_function(content_row_condition)
  function(table_tree) {
    if (is_leaf_table(table_tree)) {
      content_row <- h_content_first_row(table_tree)
      return(!content_row_condition(content_row))
    }
    if (inherits(table_tree, "DataRow")) {
      return(FALSE)
    }
    children <- tree_children(table_tree)
    identical(length(children), 0L)
  }
}

#' @describeIn prune_occurrences constructor for creating condition functions on total counts in
#'  the specified columns.
#' @param atleast (`count` or `proportion`)\cr threshold which should be met in order to
#'   keep the row.
#' @param ... arguments for row or column access, see [`rtables_access`]: either
#'   `col_names` (`character`) including the names of the columns which should be used,
#'   or alternatively `col_indices` (`integer`) giving the indices directly instead.
#' @return [has_count_in_cols()] returns a condition function that sums the counts in the specified
#'   column.
#'
#' @examples
#' # Internal function - has_count_in_cols
#' \dontrun{
#' more_than_one <- has_count_in_cols(atleast = 1L, col_names = names(tab))
#' prune_table(tab, keep_rows(more_than_one))
#' }
#'
#' @keywords internal
has_count_in_cols <- function(atleast, ...) {
  checkmate::assert_count(atleast)
  CombinationFunction(function(table_row) {
    row_counts <- h_row_counts(table_row, ...)
    total_count <- sum(row_counts)
    total_count >= atleast
  })
}

#' @describeIn prune_occurrences constructor for creating condition functions on any of the counts in
#'  the specified columns satisfying a threshold.
#' @param atleast (`count` or `proportion`)\cr threshold which should be met in order to
#'   keep the row.
#' @return [has_count_in_any_col()] returns a condition function that compares the counts in the
#'   specified columns with the threshold.
#' @export
#'
#' @examples
#' \dontrun{
#' # `has_count_in_any_col`
#' any_more_than_one <- has_count_in_any_col(atleast = 1L, col_names = names(tab))
#' prune_table(tab, keep_rows(any_more_than_one))
#' }
has_count_in_any_col <- function(atleast, ...) {
  checkmate::assert_count(atleast)
  CombinationFunction(function(table_row) {
    row_counts <- h_row_counts(table_row, ...)
    any(row_counts >= atleast)
  })
}

#' @describeIn prune_occurrences constructor for creating condition functions on total fraction in
#'  the specified columns.
#' @return [has_fraction_in_cols()] returns a condition function that sums the counts in the
#'   specified column, and computes the fraction by dividing by the total column counts.
#' @export
#'
#' @examples
#' \dontrun{
#' # `has_fraction_in_cols`
#' more_than_five_percent <- has_fraction_in_cols(atleast = 0.05, col_names = names(tab))
#' prune_table(tab, keep_rows(more_than_five_percent))
#' }
has_fraction_in_cols <- function(atleast, ...) {
  assert_proportion_value(atleast, include_boundaries = TRUE)
  CombinationFunction(function(table_row) {
    row_counts <- h_row_counts(table_row, ...)
    total_count <- sum(row_counts)
    col_counts <- h_col_counts(table_row, ...)
    total_n <- sum(col_counts)
    total_percent <- total_count / total_n
    total_percent >= atleast
  })
}

#' @describeIn prune_occurrences constructor for creating condition functions on any fraction in
#'  the specified columns.
#' @return [has_fraction_in_cols()] returns a condition function that looks at the fractions
#'  in the specified columns and checks whether any of them fulfill the threshold.
#' @export
#'
#' @examples
#' \dontrun{
#' # `has_fraction_in_any_col`
#' any_atleast_five_percent <- has_fraction_in_any_col(atleast = 0.05, col_names = names(tab))
#' prune_table(tab, keep_rows(more_than_five_percent))
#' }
has_fraction_in_any_col <- function(atleast, ...) {
  assert_proportion_value(atleast, include_boundaries = TRUE)
  CombinationFunction(function(table_row) {
    row_fractions <- h_row_fractions(table_row, ...)
    any(row_fractions >= atleast)
  })
}

#' @describeIn prune_occurrences constructor for creating condition function that checks the difference
#'   between the fractions reported in each specified column.
#' @return [has_fractions_difference()] returns a condition function that extracts the fractions of each
#'   specified column, and computes the difference of the minimum and maximum.
#' @export
#'
#' @examples
#' \dontrun{
#' # `has_fractions_difference`
#' more_than_five_percent_diff <- has_fractions_difference(atleast = 0.05, col_names = names(tab))
#' prune_table(tab, keep_rows(more_than_five_percent_diff))
#' }
has_fractions_difference <- function(atleast, ...) {
  assert_proportion_value(atleast, include_boundaries = TRUE)
  CombinationFunction(function(table_row) {
    fractions <- h_row_fractions(table_row, ...)
    difference <- diff(range(fractions))
    difference >= atleast
  })
}

#' @describeIn prune_occurrences constructor for creating condition function that checks the difference
#'   between the counts reported in each specified column.
#' @return [has_counts_difference()] returns a condition function that extracts the counts of each
#'   specified column, and computes the difference of the minimum and maximum.
#'
#' @examples
#' # Internal function - has_counts_difference
#' \dontrun{
#' more_than_one_diff <- has_counts_difference(atleast = 1L, col_names = names(tab))
#' prune_table(tab, keep_rows(more_than_one_diff))
#' }
#'
#' @keywords internal
has_counts_difference <- function(atleast, ...) {
  checkmate::assert_count(atleast)
  CombinationFunction(function(table_row) {
    counts <- h_row_counts(table_row, ...)
    difference <- diff(range(counts))
    difference >= atleast
  })
}

#' Kaplan-Meier Plot
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @param df (`data.frame`)\cr data set containing all analysis variables.
#' @param variables (named `list`)\cr variable names. Details are:
#'   * `tte` (`numeric`)\cr variable indicating time-to-event duration values.
#'   * `is_event` (`logical`)\cr event variable. `TRUE` if event, `FALSE` if time to event is censored.
#'   * `arm` (`factor`)\cr the treatment group variable.
#'   * `strat` (`character` or `NULL`)\cr variable names indicating stratification factors.
#' @param control_surv (`list`)\cr parameters for comparison details, specified by using
#'   the helper function [`control_surv_timepoint`]. Some possible parameter options are:
#'   * `conf_level` (`proportion`)\cr confidence level of the interval for survival rate.
#'   * `conf_type` (`string`)\cr "plain" (default), "log", "log-log" for confidence interval type,
#'     see more in [survival::survfit()]. Note that the option "none" is no longer supported.
#' @param data (`data.frame`)\cr survival data as pre-processed by `h_data_plot`.
#' @param xticks (`numeric`, `number`, or `NULL`)\cr numeric vector of ticks or single number with spacing
#'   between ticks on the x axis. If `NULL` (default), [labeling::extended()] is used to determine
#'   an optimal tick position on the x axis.
#' @param yval (`string`)\cr value of y-axis. Options are `Survival` (default) and `Failure` probability.
#' @param censor_show (`flag`)\cr whether to show censored.
#' @param xlab (`string`)\cr label of x-axis.
#' @param ylab (`string`)\cr label of y-axis.
#' @param title (`string`)\cr title for plot.
#' @param footnotes (`string`)\cr footnotes for plot.
#' @param col (`character`)\cr lines colors. Length of a vector should be equal
#'   to number of strata from [survival::survfit()].
#' @param lty (`numeric`)\cr line type. Length of a vector should be equal
#'   to number of strata from [survival::survfit()].
#' @param lwd (`numeric`)\cr line width. Length of a vector should be equal
#'   to number of strata from [survival::survfit()].
#' @param pch (`numeric`, `string`)\cr value or character of points symbol to indicate censored cases.
#' @param size (`numeric`)\cr size of censored point, a class of `unit`.
#' @param max_time (`numeric`)\cr maximum value to show on X axis. Only data values less than or up to
#'   this threshold value will be plotted (defaults to `NULL`).
#' @param font_size (`number`)\cr font size to be used.
#' @param ci_ribbon (`flag`)\cr draw the confidence interval around the Kaplan-Meier curve.
#' @param ggtheme (`theme`)\cr a graphical theme as provided by `ggplot2` to control outlook of the Kaplan-Meier curve.
#' @param annot_at_risk (`flag`)\cr compute and add the annotation table reporting the number of patient at risk
#'   matching the main grid of the Kaplan-Meier curve.
#' @param annot_surv_med (`flag`)\cr compute and add the annotation table on the Kaplan-Meier curve estimating the
#'   median survival time per group.
#' @param annot_coxph (`flag`)\cr add the annotation table from a [survival::coxph()] model.
#' @param annot_stats (`string`)\cr statistics annotations to add to the plot. Options are
#'   `median` (median survival follow-up time) and `min` (minimum survival follow-up time).
#' @param annot_stats_vlines (`flag`)\cr add vertical lines corresponding to each of the statistics
#'   specified by `annot_stats`. If `annot_stats` is `NULL` no lines will be added.
#' @param control_coxph_pw (`list`)\cr parameters for comparison details, specified by using
#'   the helper function [control_coxph()]. Some possible parameter options are:
#'   * `pval_method` (`string`)\cr p-value method for testing hazard ratio = 1.
#'     Default method is "log-rank", can also be set to "wald" or "likelihood".
#'   * `ties` (`string`)\cr method for tie handling. Default is "efron",
#'     can also be set to "breslow" or "exact". See more in [survival::coxph()]
#'   * `conf_level` (`proportion`)\cr confidence level of the interval for HR.
#' @param position_coxph (`numeric`)\cr x and y positions for plotting [survival::coxph()] model.
#' @param position_surv_med (`numeric`)\cr x and y positions for plotting annotation table estimating median survival
#'   time per group.
#'
#' @name kaplan_meier
NULL

#' Kaplan-Meier Plot
#'
#' @description `r lifecycle::badge("stable")`
#'
#' From a survival model, a graphic is rendered along with tabulated annotation
#' including the number of patient at risk at given time and the median survival
#' per group.
#'
#' @return a `grob` of class `gTree`.
#'
#' @inheritParams grid::gTree
#' @inheritParams kaplan_meier
#' @inheritParams argument_convention
#'
#' @export
#'
#' @examples
#' \dontrun{
#' library(dplyr)
#' library(ggplot2)
#' library(survival)
#' library(grid)
#' library(nestcolor)
#'
#' df <- tern_ex_adtte %>%
#'   filter(PARAMCD == "OS") %>%
#'   mutate(is_event = CNSR == 0)
#' variables <- list(tte = "AVAL", is_event = "is_event", arm = "ARMCD")
#'
#' # 1. Example - basic option
#'
#' res <- g_km(df = df, variables = variables)
#' res <- g_km(df = df, variables = variables, yval = "Failure")
#' res <- g_km(
#'   df = df,
#'   variables = variables,
#'   control_surv = control_surv_timepoint(conf_level = 0.9),
#'   col = c("grey25", "grey50", "grey75")
#' )
#' res <- g_km(df = df, variables = variables, ggtheme = theme_minimal())
#' res <- g_km(df = df, variables = variables, ggtheme = theme_minimal(), lty = 1:3)
#' res <- g_km(df = df, variables = variables, max = 2000)
#' res <- g_km(
#'   df = df,
#'   variables = variables,
#'   annot_stats = c("min", "median"),
#'   annot_stats_vlines = TRUE
#' )
#'
#' # 2. Example - Arrange several KM curve on a single graph device
#'
#' # 2.1 Use case: A general graph on the top, a zoom on the bottom.
#' grid.newpage()
#' lyt <- grid.layout(nrow = 2, ncol = 1) %>%
#'   viewport(layout = .) %>%
#'   pushViewport()
#'
#' res <- g_km(
#'   df = df, variables = variables, newpage = FALSE, annot_surv_med = FALSE,
#'   vp = viewport(layout.pos.row = 1, layout.pos.col = 1)
#' )
#' res <- g_km(
#'   df = df, variables = variables, max = 1000, newpage = FALSE, annot_surv_med = FALSE,
#'   ggtheme = theme_dark(),
#'   vp = viewport(layout.pos.row = 2, layout.pos.col = 1)
#' )
#'
#' # 2.1 Use case: No annotations on top, annotated graph on bottom
#' grid.newpage()
#' lyt <- grid.layout(nrow = 2, ncol = 1) %>%
#'   viewport(layout = .) %>%
#'   pushViewport()
#'
#' res <- g_km(
#'   df = df, variables = variables, newpage = FALSE,
#'   annot_surv_med = FALSE, annot_at_risk = FALSE,
#'   vp = viewport(layout.pos.row = 1, layout.pos.col = 1)
#' )
#' res <- g_km(
#'   df = df, variables = variables, max = 2000, newpage = FALSE, annot_surv_med = FALSE,
#'   annot_at_risk = TRUE,
#'   ggtheme = theme_dark(),
#'   vp = viewport(layout.pos.row = 2, layout.pos.col = 1)
#' )
#'
#' # Add annotation from a pairwise coxph analysis
#' g_km(
#'   df = df, variables = variables,
#'   annot_coxph = TRUE
#' )
#'
#' g_km(
#'   df = df, variables = c(variables, list(strat = "SEX")),
#'   font_size = 15,
#'   annot_coxph = TRUE,
#'   control_coxph = control_coxph(pval_method = "wald", ties = "exact", conf_level = 0.99),
#'   position_coxph = c(0.4, 0.5)
#' )
#'
#' # Change position of the treatment group annotation table.
#' g_km(
#'   df = df, variables = c(variables, list(strat = "SEX")),
#'   font_size = 15,
#'   annot_coxph = TRUE,
#'   control_coxph = control_coxph(pval_method = "wald", ties = "exact", conf_level = 0.99),
#'   position_surv_med = c(1, 0.7)
#' )
#' }
g_km <- function(df,
                 variables,
                 control_surv = control_surv_timepoint(),
                 col = NULL,
                 lty = NULL,
                 lwd = .5,
                 censor_show = TRUE,
                 pch = 3,
                 size = 2,
                 max_time = NULL,
                 xticks = NULL,
                 xlab = "Days",
                 yval = c("Survival", "Failure"),
                 ylab = paste(yval, "Probability"),
                 title = NULL,
                 footnotes = NULL,
                 draw = TRUE,
                 newpage = TRUE,
                 gp = NULL,
                 vp = NULL,
                 name = NULL,
                 font_size = 12,
                 ci_ribbon = FALSE,
                 ggtheme = nestcolor::theme_nest(),
                 annot_at_risk = TRUE,
                 annot_surv_med = TRUE,
                 annot_coxph = FALSE,
                 annot_stats = NULL,
                 annot_stats_vlines = FALSE,
                 control_coxph_pw = control_coxph(),
                 position_coxph = c(0, 0.05),
                 position_surv_med = c(0.9, 0.9)) {
  checkmate::assert_list(variables)
  checkmate::assert_subset(c("tte", "arm", "is_event"), names(variables))
  checkmate::assert_string(title, null.ok = TRUE)
  checkmate::assert_string(footnotes, null.ok = TRUE)
  checkmate::assert_character(col, null.ok = TRUE)
  checkmate::assert_subset(annot_stats, c("median", "min"))
  checkmate::assert_logical(annot_stats_vlines)

  tte <- variables$tte
  is_event <- variables$is_event
  arm <- variables$arm

  assert_valid_factor(df[[arm]])
  assert_df_with_variables(df, list(tte = tte, is_event = is_event, arm = arm))
  checkmate::assert_logical(df[[is_event]], min.len = 1, any.missing = FALSE)
  checkmate::assert_numeric(df[[tte]], min.len = 1, any.missing = FALSE)

  armval <- as.character(unique(df[[arm]]))
  if (length(armval) > 1) {
    armval <- NULL
  }
  yval <- match.arg(yval)
  formula <- stats::as.formula(paste0("survival::Surv(", tte, ", ", is_event, ") ~ ", arm))
  fit_km <- survival::survfit(
    formula = formula,
    data = df,
    conf.int = control_surv$conf_level,
    conf.type = control_surv$conf_type
  )
  data_plot <- h_data_plot(
    fit_km = fit_km,
    armval = armval,
    max_time = max_time
  )

  xticks <- h_xticks(data = data_plot, xticks = xticks, max_time = max_time)
  gg <- h_ggkm(
    data = data_plot,
    censor_show = censor_show,
    pch = pch,
    size = size,
    xticks = xticks,
    xlab = xlab,
    yval = yval,
    ylab = ylab,
    title = title,
    footnotes = footnotes,
    max_time = max_time,
    lwd = lwd,
    lty = lty,
    col = col,
    ggtheme = ggtheme,
    ci_ribbon = ci_ribbon
  )

  if (!is.null(annot_stats)) {
    if ("median" %in% annot_stats) {
      fit_km_all <- survival::survfit(
        formula = stats::as.formula(paste0("survival::Surv(", tte, ", ", is_event, ") ~ ", 1)),
        data = df,
        conf.int = control_surv$conf_level,
        conf.type = control_surv$conf_type
      )
      gg <- gg +
        geom_text(
          size = 8 / ggplot2::.pt, col = 1,
          x = stats::median(fit_km_all) + 0.065 * max(data_plot$time),
          y = ifelse(yval == "Survival", 0.62, 0.38),
          label = paste("Median F/U:\n", round(stats::median(fit_km_all), 1), tolower(df$AVALU[1]))
        )
      if (annot_stats_vlines) {
        gg <- gg +
          geom_segment(aes(x = stats::median(fit_km_all), xend = stats::median(fit_km_all), y = -Inf, yend = Inf),
            linetype = 2, col = "darkgray"
          )
      }
    }
    if ("min" %in% annot_stats) {
      min_fu <- min(df[[tte]])
      gg <- gg +
        geom_text(
          size = 8 / ggplot2::.pt, col = 1,
          x = min_fu + max(data_plot$time) * ifelse(yval == "Survival", 0.05, 0.07),
          y = ifelse(yval == "Survival", 1.0, 0.05),
          label = paste("Min. F/U:\n", round(min_fu, 1), tolower(df$AVALU[1]))
        )
      if (annot_stats_vlines) {
        gg <- gg +
          geom_segment(aes(x = min_fu, xend = min_fu, y = Inf, yend = -Inf), linetype = 2, col = "darkgray")
      }
    }
    gg <- gg + ggplot2::guides(fill = ggplot2::guide_legend(override.aes = list(shape = NA, label = "")))
  }

  g_el <- h_decompose_gg(gg)

  if (annot_at_risk) {
    # This is the content of the table that will be below the graph.
    annot_tbl <- summary(fit_km, time = xticks)
    annot_tbl <- if (is.null(fit_km$strata)) {
      data.frame(
        n.risk = annot_tbl$n.risk,
        time = annot_tbl$time,
        strata = as.factor(armval)
      )
    } else {
      strata_lst <- strsplit(sub("=", "equals", levels(annot_tbl$strata)), "equals")
      levels(annot_tbl$strata) <- matrix(unlist(strata_lst), ncol = 2, byrow = TRUE)[, 2]
      data.frame(
        n.risk = annot_tbl$n.risk,
        time = annot_tbl$time,
        strata = annot_tbl$strata
      )
    }

    grobs_patient <- h_grob_tbl_at_risk(
      data = data_plot,
      annot_tbl = annot_tbl,
      xlim = max(max_time, data_plot$time, xticks)
    )
  }

  if (annot_at_risk || annot_surv_med || annot_coxph) {
    lyt <- h_km_layout(data = data_plot, g_el = g_el, title = title, footnotes = footnotes, annot_at_risk = annot_at_risk) # nolint
    ttl_row <- as.numeric(!is.null(title))
    foot_row <- as.numeric(!is.null(footnotes))
    km_grob <- grid::gTree(
      vp = grid::viewport(layout = lyt, height = .95, width = .95),
      children = grid::gList(
        # Title.
        if (ttl_row == 1) {
          grid::gTree(
            vp = grid::viewport(layout.pos.row = 1, layout.pos.col = 2),
            children = grid::gList(grid::textGrob(label = title, x = grid::unit(0, "npc"), hjust = 0))
          )
        },

        # The Kaplan - Meier curve (top-right corner).
        grid::gTree(
          vp = grid::viewport(layout.pos.row = 1 + ttl_row, layout.pos.col = 2),
          children = grid::gList(g_el$panel)
        ),

        # Survfit summary table (top-right corner).
        if (annot_surv_med) {
          grid::gTree(
            vp = grid::viewport(layout.pos.row = 1 + ttl_row, layout.pos.col = 2),
            children = h_grob_median_surv(
              fit_km = fit_km,
              armval = armval,
              x = position_surv_med[1],
              y = position_surv_med[2],
              ttheme = gridExtra::ttheme_default(base_size = font_size)
            )
          )
        },
        if (annot_coxph) {
          grid::gTree(
            vp = grid::viewport(layout.pos.row = 1 + ttl_row, layout.pos.col = 2),
            children = h_grob_coxph(
              df = df,
              variables = variables,
              control_coxph_pw = control_coxph_pw,
              x = position_coxph[1],
              y = position_coxph[2],
              ttheme = gridExtra::ttheme_default(
                base_size = font_size,
                padding = grid::unit(c(1, .5), "lines"),
                core = list(bg_params = list(fill = c("grey95", "grey90"), alpha = .5))
              )
            )
          )
        },

        # Add the y-axis annotation (top-left corner).
        grid::gTree(
          vp = grid::viewport(layout.pos.row = 1 + ttl_row, layout.pos.col = 1),
          children = h_grob_y_annot(ylab = g_el$ylab, yaxis = g_el$yaxis)
        ),

        # Add the x-axis annotation (second row below the Kaplan Meier Curve).
        grid::gTree(
          vp = grid::viewport(layout.pos.row = 2 + ttl_row, layout.pos.col = 2),
          children = grid::gList(rbind(g_el$xaxis, g_el$xlab))
        ),

        # Add the legend.
        grid::gTree(
          vp = grid::viewport(layout.pos.row = 3 + ttl_row, layout.pos.col = 2),
          children = grid::gList(g_el$guide)
        ),

        # Add the table with patient-at-risk numbers.
        if (annot_at_risk) {
          grid::gTree(
            vp = grid::viewport(layout.pos.row = 4 + ttl_row, layout.pos.col = 2),
            children = grobs_patient$at_risk
          )
        },
        if (annot_at_risk) {
          grid::gTree(
            vp = grid::viewport(layout.pos.row = 4 + ttl_row, layout.pos.col = 1),
            children = grobs_patient$label
          )
        },
        if (annot_at_risk) {
          # Add the x-axis for the table.
          grid::gTree(
            vp = grid::viewport(layout.pos.row = 5 + ttl_row, layout.pos.col = 2),
            children = grid::gList(rbind(g_el$xaxis, g_el$xlab))
          )
        },

        # Footnotes.
        if (foot_row == 1) {
          grid::gTree(
            vp = grid::viewport(
              layout.pos.row = ifelse(annot_at_risk, 6 + ttl_row, 4 + ttl_row),
              layout.pos.col = 2
            ),
            children = grid::gList(grid::textGrob(label = footnotes, x = grid::unit(0, "npc"), hjust = 0))
          )
        }
      )
    )

    result <- grid::gTree(
      vp = vp,
      gp = gp,
      name = name,
      children = grid::gList(km_grob)
    )
  } else {
    result <- grid::gTree(
      vp = vp,
      gp = gp,
      name = name,
      children = grid::gList(ggplot2::ggplotGrob(gg))
    )
  }

  if (newpage && draw) grid::grid.newpage()
  if (draw) grid::grid.draw(result)
  invisible(result)
}

#' Helper function: tidy survival fit
#'
#' @description`r lifecycle::badge("stable")`
#'
#' Convert the survival fit data into a data frame designed for plotting
#' within `g_km`.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This starts from the [broom::tidy()] result, and then:
#' - post-processes the `strata` column into a factor,
#' - extends each stratum by an additional first row with time 0
#' and probability 1 so that downstream plot lines start at those coordinates,
#' - adds a `censor` column,
#' - filters the rows before `max_time`.
#'
#' @inheritParams kaplan_meier
#' @param fit_km (`survfit`)\cr result of [survival::survfit()].
#' @param armval (`string`)\cr used as strata name when treatment arm
#' variable only has one level. Default is "All".
#' @examples
#' \dontrun{
#' library(dplyr)
#' library(survival)
#'
#' # Test with multiple arms
#' tern_ex_adtte %>%
#'   filter(PARAMCD == "OS") %>%
#'   survfit(form = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) %>%
#'   h_data_plot()
#'
#' # Test with single arm
#' tern_ex_adtte %>%
#'   filter(PARAMCD == "OS", ARMCD == "ARM B") %>%
#'   survfit(form = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) %>%
#'   h_data_plot(armval = "ARM B")
#' }
#'
#' @export
h_data_plot <- function(fit_km,
                        armval = "All",
                        max_time = NULL) {
  y <- broom::tidy(fit_km)

  if (!is.null(fit_km$strata)) {
    fit_km_var_level <- strsplit(sub("=", "equals", names(fit_km$strata)), "equals")
    strata_levels <- vapply(fit_km_var_level, FUN = "[", FUN.VALUE = "a", i = 2)
    strata_var_level <- strsplit(sub("=", "equals", y$strata), "equals")
    y$strata <- factor(
      vapply(strata_var_level, FUN = "[", FUN.VALUE = "a", i = 2),
      levels = strata_levels
    )
  } else {
    y$strata <- armval
  }

  y_by_strata <- split(y, y$strata)
  y_by_strata_extended <- lapply(
    y_by_strata,
    FUN = function(tbl) {
      first_row <- tbl[1L, ]
      first_row$time <- 0
      # nolint start
      first_row$n.risk <- sum(first_row[, c("n.risk", "n.event", "n.censor")])
      first_row$n.event <- first_row$n.censor <- 0
      first_row$estimate <- first_row$conf.high <- first_row$conf.low <- 1
      first_row$std.error <- 0
      # nolint end
      rbind(
        first_row,
        tbl
      )
    }
  )
  y <- do.call(rbind, y_by_strata_extended)

  y$censor <- ifelse(y$n.censor > 0, y$estimate, NA)
  if (!is.null(max_time)) {
    y <- y[y$time <= max(max_time), ]
  }
  y
}

#' Helper function: x tick positions
#'
#' @description`r lifecycle::badge("stable")`
#'
#' Calculate the positions of ticks on the x-axis. However, if `xticks` already
#' exists it is kept as is. It is based on the same function `ggplot2` relies on,
#' and is required in the graphic and the patient-at-risk annotation table.
#'
#' @inheritParams kaplan_meier
#'
#' @examples
#' \dontrun{
#' library(dplyr)
#' library(survival)
#'
#' data <- tern_ex_adtte %>%
#'   filter(PARAMCD == "OS") %>%
#'   survfit(form = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) %>%
#'   h_data_plot()
#'
#' h_xticks(data)
#' h_xticks(data, xticks = seq(0, 3000, 500))
#' h_xticks(data, xticks = 500)
#' h_xticks(data, xticks = 500, max_time = 6000)
#' h_xticks(data, xticks = c(0, 500), max_time = 300)
#' h_xticks(data, xticks = 500, max_time = 300)
#' }
#'
#' @export
h_xticks <- function(data, xticks = NULL, max_time = NULL) {
  if (is.null(xticks)) {
    if (is.null(max_time)) {
      labeling::extended(range(data$time)[1], range(data$time)[2], m = 5)
    } else {
      labeling::extended(range(data$time)[1], max(range(data$time)[2], max_time), m = 5)
    }
  } else if (checkmate::test_number(xticks)) {
    if (is.null(max_time)) {
      seq(0, max(data$time), xticks)
    } else {
      seq(0, max(data$time, max_time), xticks)
    }
  } else if (is.numeric(xticks)) {
    xticks
  } else {
    stop(
      paste(
        "xticks should be either `NULL`",
        "or a single number (interval between x ticks)",
        "or a numeric vector (position of ticks on the x axis)"
      )
    )
  }
}

#' Helper function: KM plot
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Draw the Kaplan-Meier plot using `ggplot2`.
#'
#' @inheritParams kaplan_meier
#' @examples
#' \dontrun{
#' library(dplyr)
#' library(survival)
#'
#' fit_km <- tern_ex_adtte %>%
#'   filter(PARAMCD == "OS") %>%
#'   survfit(form = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .)
#' data_plot <- h_data_plot(fit_km = fit_km)
#' xticks <- h_xticks(data = data_plot)
#' gg <- h_ggkm(
#'   data = data_plot,
#'   censor_show = TRUE,
#'   xticks = xticks,
#'   xlab = "Days",
#'   yval = "Survival",
#'   ylab = "Survival Probability",
#'   title = "Survival"
#' )
#' gg
#' }
#'
#' @export
h_ggkm <- function(data,
                   xticks = NULL,
                   yval = "Survival",
                   censor_show,
                   xlab,
                   ylab,
                   title,
                   footnotes = NULL,
                   max_time = NULL,
                   lwd = 1,
                   lty = NULL,
                   pch = 3,
                   size = 2,
                   col = NULL,
                   ci_ribbon = FALSE,
                   ggtheme = nestcolor::theme_nest()) {
  checkmate::assert_numeric(lty, null.ok = TRUE)
  checkmate::assert_character(col, null.ok = TRUE)

  # change estimates of survival to estimates of failure (1 - survival)
  if (yval == "Failure") {
    data$estimate <- 1 - data$estimate
    data[c("conf.high", "conf.low")] <- list(1 - data$conf.low, 1 - data$conf.high)
    data$censor <- 1 - data$censor
  }

  gg <- {
    ggplot2::ggplot(
      data = data,
      mapping = ggplot2::aes(
        x = .data[["time"]],
        y = .data[["estimate"]],
        ymin = .data[["conf.low"]],
        ymax = .data[["conf.high"]],
        color = .data[["strata"]],
        fill = .data[["strata"]]
      )
    ) +
      ggplot2::geom_hline(yintercept = 0)
  }

  if (ci_ribbon) {
    gg <- gg + ggplot2::geom_ribbon(alpha = .3, lty = 0)
  }

  gg <- if (is.null(lty)) {
    gg +
      ggplot2::geom_step(linewidth = lwd)
  } else if (checkmate::test_number(lty)) {
    gg +
      ggplot2::geom_step(linewidth = lwd, lty = lty)
  } else if (is.numeric(lty)) {
    gg +
      ggplot2::geom_step(mapping = ggplot2::aes(linetype = .data[["strata"]]), linewidth = lwd) +
      ggplot2::scale_linetype_manual(values = lty)
  }

  gg <- gg +
    ggplot2::coord_cartesian(ylim = c(0, 1)) +
    ggplot2::labs(x = xlab, y = ylab, title = title, caption = footnotes)

  if (!is.null(col)) {
    gg <- gg +
      ggplot2::scale_color_manual(values = col) +
      ggplot2::scale_fill_manual(values = col)
  }
  if (censor_show) {
    dt <- data[data$n.censor != 0, ]
    dt$censor_lbl <- factor("Censored")

    gg <- gg + ggplot2::geom_point(
      data = dt,
      ggplot2::aes(
        x = .data[["time"]],
        y = .data[["censor"]],
        shape = .data[["censor_lbl"]]
      ),
      size = size,
      show.legend = TRUE,
      inherit.aes = TRUE
    ) +
      ggplot2::scale_shape_manual(name = NULL, values = pch) +
      ggplot2::guides(
        shape = ggplot2::guide_legend(override.aes = list(linetype = NA)),
        fill = ggplot2::guide_legend(override.aes = list(shape = NA))
      )
  }


  if (!is.null(max_time) && !is.null(xticks)) {
    gg <- gg + ggplot2::scale_x_continuous(breaks = xticks, limits = c(min(0, xticks), max(c(xticks, max_time))))
  } else if (!is.null(xticks)) {
    if (max(data$time) <= max(xticks)) {
      gg <- gg + ggplot2::scale_x_continuous(breaks = xticks, limits = c(min(0, min(xticks)), max(xticks)))
    } else {
      gg <- gg + ggplot2::scale_x_continuous(breaks = xticks)
    }
  } else if (!is.null(max_time)) {
    gg <- gg + ggplot2::scale_x_continuous(limits = c(0, max_time))
  }


  if (!is.null(ggtheme)) {
    gg <- gg + ggtheme
  }

  gg + ggplot2::theme(
    legend.position = "bottom",
    legend.title = ggplot2::element_blank(),
    panel.grid.major.x = ggplot2::element_line(linewidth = 2)
  )
}

#' `ggplot` Decomposition
#'
#' @description `r lifecycle::badge("stable")`
#'
#' The elements composing the `ggplot` are extracted and organized in a
#' list containing:
#' the panel (`panel`),
#' the y-axis and its label (`yaxis`, `ylab`),
#' idem for the x-axis (`xaxis`, `xlab`),
#' the legend (`guide`).
#'
#' @param gg (`ggplot`)\cr a graphic to decompose.
#'
#' @examples
#' \dontrun{
#' library(dplyr)
#' library(survival)
#' library(grid)
#'
#' fit_km <- tern_ex_adtte %>%
#'   filter(PARAMCD == "OS") %>%
#'   survfit(form = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .)
#' data_plot <- h_data_plot(fit_km = fit_km)
#' xticks <- h_xticks(data = data_plot)
#' gg <- h_ggkm(
#'   data = data_plot,
#'   yval = "Survival",
#'   censor_show = TRUE,
#'   xticks = xticks, xlab = "Days", ylab = "Survival Probability",
#'   title = "tt",
#'   footnotes = "ff"
#' )
#'
#' g_el <- h_decompose_gg(gg)
#' grid::grid.newpage()
#' grid.rect(gp = grid::gpar(lty = 1, col = "red", fill = "gray85", lwd = 5))
#' grid::grid.draw(g_el$panel)
#'
#' grid::grid.newpage()
#' grid.rect(gp = grid::gpar(lty = 1, col = "royalblue", fill = "gray85", lwd = 5))
#' grid::grid.draw(with(g_el, cbind(ylab, yaxis)))
#' }
#'
#' @export
h_decompose_gg <- function(gg) {
  g_el <- ggplot2::ggplotGrob(gg)
  y <- c(
    panel = "panel",
    yaxis = "axis-l",
    xaxis = "axis-b",
    xlab = "xlab-b",
    ylab = "ylab-l",
    guide = "guide"
  )
  lapply(X = y, function(x) gtable::gtable_filter(g_el, x))
}


#' Helper: KM Layout
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Prepares a (5 rows) x (2 cols) layout for the Kaplan-Meier curve.
#'
#' @inheritParams kaplan_meier
#' @param g_el (`list` of `gtable`)\cr list as obtained by `h_decompose_gg()`.
#' @param annot_at_risk (`flag`)\cr compute and add the annotation table
#'   reporting the number of patient at risk matching the main grid of the
#'   Kaplan-Meier curve.
#' @export
#'
#' @details
#' The layout corresponds to a grid of two columns and five rows of unequal
#' dimensions. Most of the dimension are fixed, only the curve is flexible and
#' will accommodate with the remaining free space.
#' - The left column gets the annotation of the `ggplot` (y-axis) and the
#'   names of the strata for the patient at risk tabulation.
#'   The main constraint is about the width of the columns which must allow the
#'   writing of the strata name.
#' - The right column receive the `ggplot`, the legend, the x-axis and the
#' patient at risk table.
#'
#' @examples
#' \dontrun{
#' library(dplyr)
#' library(survival)
#'
#' fit_km <- tern_ex_adtte %>%
#'   filter(PARAMCD == "OS") %>%
#'   survfit(form = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .)
#' data_plot <- h_data_plot(fit_km = fit_km)
#' xticks <- h_xticks(data = data_plot)
#' gg <- h_ggkm(
#'   data = data_plot,
#'   censor_show = TRUE,
#'   xticks = xticks, xlab = "Days", ylab = "Survival Probability",
#'   title = "tt", footnotes = "ff", yval = "Survival"
#' )
#' g_el <- h_decompose_gg(gg)
#' lyt <- h_km_layout(data = data_plot, g_el = g_el, title = "t", footnotes = "f")
#' grid.show.layout(lyt)
#' }
#'
h_km_layout <- function(data, g_el, title, footnotes, annot_at_risk = TRUE) {
  txtlines <- levels(as.factor(data$strata))
  nlines <- nlevels(as.factor(data$strata))
  col_annot_width <- max(
    c(
      as.numeric(grid::convertX(g_el$yaxis$width + g_el$ylab$width, "pt")),
      as.numeric(
        grid::convertX(
          grid::stringWidth(txtlines) + grid::unit(7, "pt"), "pt"
        )
      )
    )
  )

  ttl_row <- as.numeric(!is.null(title))
  foot_row <- as.numeric(!is.null(footnotes))
  no_tbl_ind <- c()
  ht_x <- c()
  ht_units <- c()

  if (ttl_row == 1) {
    no_tbl_ind <- c(no_tbl_ind, TRUE)
    ht_x <- c(ht_x, 2)
    ht_units <- c(ht_units, "lines")
  }

  no_tbl_ind <- c(no_tbl_ind, rep(TRUE, 3), rep(FALSE, 2))
  ht_x <- c(
    ht_x,
    1,
    grid::convertX(with(g_el, xaxis$height + ylab$width), "pt"),
    grid::convertX(g_el$guide$heights, "pt"),
    nlines + 1,
    grid::convertX(with(g_el, xaxis$height + ylab$width), "pt")
  )
  ht_units <- c(
    ht_units,
    "null",
    "pt",
    "pt",
    "lines",
    "pt"
  )

  if (foot_row == 1) {
    no_tbl_ind <- c(no_tbl_ind, TRUE)
    ht_x <- c(ht_x, 1)
    ht_units <- c(ht_units, "lines")
  }

  no_at_risk_tbl <- if (annot_at_risk) {
    rep(TRUE, 5 + ttl_row + foot_row)
  } else {
    no_tbl_ind
  }

  grid::grid.layout(
    nrow = sum(no_at_risk_tbl), ncol = 2,
    widths = grid::unit(c(col_annot_width, 1), c("pt", "null")),
    heights = grid::unit(
      x = ht_x[no_at_risk_tbl],
      units = ht_units[no_at_risk_tbl]
    )
  )
}

#' Helper: Patient-at-Risk Grobs
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Two Graphical Objects are obtained, one corresponding to row labeling and
#' the second to the number of patient at risk.
#'
#' @inheritParams kaplan_meier
#' @param annot_tbl (`data.frame`)\cr annotation as prepared
#'   by [survival::summary.survfit()] which includes the number of
#'   patients at risk at given time points.
#' @param xlim (`numeric`)\cr the maximum value on the x-axis (used to
#'   ensure the at risk table aligns with the KM graph).
#'
#' @examples
#' \dontrun{
#' library(dplyr)
#' library(survival)
#' library(grid)
#'
#' fit_km <- tern_ex_adtte %>%
#'   filter(PARAMCD == "OS") %>%
#'   survfit(form = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .)
#'
#' data_plot <- h_data_plot(fit_km = fit_km)
#'
#' xticks <- h_xticks(data = data_plot)
#'
#' gg <- h_ggkm(
#'   data = data_plot,
#'   censor_show = TRUE,
#'   xticks = xticks, xlab = "Days", ylab = "Survival Probability",
#'   title = "tt", footnotes = "ff", yval = "Survival"
#' )
#'
#' # The annotation table reports the patient at risk for a given strata and
#' # time (`xticks`).
#' annot_tbl <- summary(fit_km, time = xticks)
#' if (is.null(fit_km$strata)) {
#'   annot_tbl <- with(annot_tbl, data.frame(n.risk = n.risk, time = time, strata = "All"))
#' } else {
#'   strata_lst <- strsplit(sub("=", "equals", levels(annot_tbl$strata)), "equals")
#'   levels(annot_tbl$strata) <- matrix(unlist(strata_lst), ncol = 2, byrow = TRUE)[, 2]
#'   annot_tbl <- data.frame(
#'     n.risk = annot_tbl$n.risk,
#'     time = annot_tbl$time,
#'     strata = annot_tbl$strata
#'   )
#' }
#'
#' # The annotation table is transformed into a grob.
#' tbl <- h_grob_tbl_at_risk(data = data_plot, annot_tbl = annot_tbl, xlim = max(xticks))
#'
#' # For the representation, the layout is estimated for which the decomposition
#' # of the graphic element is necessary.
#' g_el <- h_decompose_gg(gg)
#' lyt <- h_km_layout(data = data_plot, g_el = g_el, title = "t", footnotes = "f")
#'
#' grid::grid.newpage()
#' pushViewport(viewport(layout = lyt, height = .95, width = .95))
#' grid.rect(gp = grid::gpar(lty = 1, col = "purple", fill = "gray85", lwd = 1))
#' pushViewport(viewport(layout.pos.row = 4, layout.pos.col = 2))
#' grid.rect(gp = grid::gpar(lty = 1, col = "orange", fill = "gray85", lwd = 1))
#' grid::grid.draw(tbl$at_risk)
#' popViewport()
#' pushViewport(viewport(layout.pos.row = 4, layout.pos.col = 1))
#' grid.rect(gp = grid::gpar(lty = 1, col = "green3", fill = "gray85", lwd = 1))
#' grid::grid.draw(tbl$label)
#' }
#'
#' @export
h_grob_tbl_at_risk <- function(data, annot_tbl, xlim) {
  txtlines <- levels(as.factor(data$strata))
  nlines <- nlevels(as.factor(data$strata))
  y_str_unit <- as.numeric(annot_tbl$strata)
  vp_table <- grid::plotViewport(margins = grid::unit(c(0, 0, 0, 0), "lines"))
  gb_table_left_annot <- grid::gList(
    grid::rectGrob(
      x = 0, y = grid::unit(c(1:nlines) - 1, "lines"),
      gp = grid::gpar(fill = c("gray95", "gray90"), alpha = 1, col = "white"),
      height = grid::unit(1, "lines"), just = "bottom", hjust = 0
    ),
    grid::textGrob(
      label = unique(annot_tbl$strata),
      x = .95,
      y = grid::unit(
        (max(unique(y_str_unit)) - unique(y_str_unit)) + .5,
        "native"
      ),
      hjust = 1,
      gp = grid::gpar(fontface = "italic", fontsize = 10)
    )
  )
  gb_patient_at_risk <- grid::gList(
    grid::rectGrob(
      x = 0, y = grid::unit(c(1:nlines) - 1, "lines"),
      gp = grid::gpar(fill = c("gray95", "gray90"), alpha = 1, col = "white"),
      height = grid::unit(1, "lines"), just = "bottom", hjust = 0
    ),
    grid::textGrob(
      label = annot_tbl$n.risk,
      x = grid::unit(annot_tbl$time, "native"),
      y = grid::unit(
        (max(y_str_unit) - y_str_unit) + .5,
        "line"
      ) # maybe native
    )
  )

  list(
    at_risk = grid::gList(
      grid::gTree(
        vp = vp_table,
        children = grid::gList(
          grid::gTree(
            vp = grid::dataViewport(
              xscale = c(0, xlim) + c(-0.05, 0.05) * xlim,
              yscale = c(0, nlines + 1),
              extension = c(0.05, 0)
            ),
            children = grid::gList(gb_patient_at_risk)
          )
        )
      )
    ),
    label = grid::gList(
      grid::gTree(
        vp = grid::viewport(width = max(grid::stringWidth(txtlines))),
        children = grid::gList(
          grid::gTree(
            vp = grid::dataViewport(
              xscale = 0:1,
              yscale = c(0, nlines + 1),
              extension = c(0.0, 0)
            ),
            children = grid::gList(gb_table_left_annot)
          )
        )
      )
    )
  )
}

#' Helper Function: Survival Estimations
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Transform a survival fit to a table with groups in rows characterized
#' by N, median and confidence interval.
#'
#' @inheritParams h_data_plot
#'
#' @examples
#' \dontrun{
#' library(dplyr)
#' library(survival)
#'
#' adtte <- tern_ex_adtte %>% filter(PARAMCD == "OS")
#' fit <- survfit(
#'   form = Surv(AVAL, 1 - CNSR) ~ ARMCD,
#'   data = adtte
#' )
#' h_tbl_median_surv(fit_km = fit)
#' }
#'
#' @export
h_tbl_median_surv <- function(fit_km, armval = "All") {
  y <- if (is.null(fit_km$strata)) {
    as.data.frame(t(summary(fit_km)$table), row.names = armval)
  } else {
    tbl <- summary(fit_km)$table
    rownames_lst <- strsplit(sub("=", "equals", rownames(tbl)), "equals")
    rownames(tbl) <- matrix(unlist(rownames_lst), ncol = 2, byrow = TRUE)[, 2]
    as.data.frame(tbl)
  }
  conf.int <- summary(fit_km)$conf.int # nolint
  y$records <- round(y$records)
  y$median <- signif(y$median, 4)
  y$`CI` <- paste0(
    "(", signif(y[[paste0(conf.int, "LCL")]], 4), ", ", signif(y[[paste0(conf.int, "UCL")]], 4), ")"
  )
  stats::setNames(
    y[c("records", "median", "CI")],
    c("N", "Median", f_conf_level(conf.int))
  )
}


#' Helper Function: Survival Estimation Grob
#'
#' @description `r lifecycle::badge("stable")`
#'
#' The survival fit is transformed in a grob containing a table with groups in
#' rows characterized by N, median and 95% confidence interval.
#'
#' @inheritParams kaplan_meier
#' @param ttheme (`list`)\cr see [gridExtra::ttheme_default()].
#' @param x a `numeric` value between 0 and 1 specifying x-location.
#' @param y a `numeric` value between 0 and 1 specifying y-location.
#' @inheritParams h_data_plot
#'
#' @examples
#' \dontrun{
#' library(dplyr)
#' library(survival)
#' library(grid)
#'
#' grid::grid.newpage()
#' grid.rect(gp = grid::gpar(lty = 1, col = "pink", fill = "gray85", lwd = 1))
#' tern_ex_adtte %>%
#'   filter(PARAMCD == "OS") %>%
#'   survfit(form = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .) %>%
#'   h_grob_median_surv() %>%
#'   grid::grid.draw()
#' }
#'
#' @export
h_grob_median_surv <- function(fit_km,
                               armval = "All",
                               x = 0.9,
                               y = 0.9,
                               ttheme = gridExtra::ttheme_default()) {
  data <- h_tbl_median_surv(fit_km, armval = armval)
  gt <- gridExtra::tableGrob(d = data, theme = ttheme)
  vp <- grid::viewport(
    x = grid::unit(x, "npc") + grid::unit(1, "lines"),
    y = grid::unit(y, "npc") + grid::unit(1.5, "lines"),
    height = sum(gt$heights),
    width = sum(gt$widths),
    just = c("right", "top")
  )

  grid::gList(
    grid::gTree(
      vp = vp,
      children = grid::gList(gt)
    )
  )
}

#' Helper: Grid Object with y-axis Annotation
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Build the y-axis annotation from a decomposed `ggplot`.
#'
#' @param ylab (`gtable`)\cr the y-lab as a graphical object derived from
#'   a `ggplot`.
#' @param yaxis (`gtable`)\cr the y-axis as a graphical object derived from
#'   a `ggplot`.
#'
#' @examples
#' \dontrun{
#' library(dplyr)
#' library(survival)
#' library(grid)
#'
#' fit_km <- tern_ex_adtte %>%
#'   filter(PARAMCD == "OS") %>%
#'   survfit(form = Surv(AVAL, 1 - CNSR) ~ ARMCD, data = .)
#' data_plot <- h_data_plot(fit_km = fit_km)
#' xticks <- h_xticks(data = data_plot)
#' gg <- h_ggkm(
#'   data = data_plot,
#'   censor_show = TRUE,
#'   xticks = xticks, xlab = "Days", ylab = "Survival Probability",
#'   title = "title", footnotes = "footnotes", yval = "Survival"
#' )
#'
#' g_el <- h_decompose_gg(gg)
#'
#' grid::grid.newpage()
#' pvp <- grid::plotViewport(margins = c(5, 4, 2, 20))
#' pushViewport(pvp)
#' grid::grid.draw(h_grob_y_annot(ylab = g_el$ylab, yaxis = g_el$yaxis))
#' grid.rect(gp = grid::gpar(lty = 1, col = "gray35", fill = NA))
#' }
#'
#' @export
h_grob_y_annot <- function(ylab, yaxis) {
  grid::gList(
    grid::gTree(
      vp = grid::viewport(
        width = grid::convertX(yaxis$width + ylab$width, "pt"),
        x = grid::unit(1, "npc"),
        just = "right"
      ),
      children = grid::gList(cbind(ylab, yaxis))
    )
  )
}

#' Helper Function: Pairwise CoxPH table
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Create an `rtable` of pairwise stratified or unstratified CoxPH analysis results.
#'
#' @inheritParams g_km
#' @export
#'
#' @examples
#' \dontrun{
#' library(dplyr)
#'
#' adtte <- tern_ex_adtte %>%
#'   filter(PARAMCD == "OS") %>%
#'   mutate(is_event = CNSR == 0)
#'
#' h_tbl_coxph_pairwise(
#'   df = adtte,
#'   variables = list(tte = "AVAL", is_event = "is_event", arm = "ARM"),
#'   control_coxph_pw = control_coxph(conf_level = 0.9)
#' )
#' }
h_tbl_coxph_pairwise <- function(df,
                                 variables,
                                 control_coxph_pw = control_coxph()) {
  assert_df_with_variables(df, variables)
  arm <- variables$arm
  df[[arm]] <- factor(df[[arm]])
  ref_group <- levels(df[[arm]])[1]
  comp_group <- levels(df[[arm]])[-1]
  results <- Map(function(comp) {
    res <- s_coxph_pairwise(
      df = df[df[[arm]] == comp, , drop = FALSE],
      .ref_group = df[df[[arm]] == ref_group, , drop = FALSE],
      .in_ref_col = FALSE,
      .var = variables$tte,
      is_event = variables$is_event,
      strat = variables$strat,
      control = control_coxph_pw
    )
    res_df <- data.frame(
      hr = format(round(res$hr, 2), nsmall = 2),
      hr_ci = paste0(
        "(", format(round(res$hr_ci[1], 2), nsmall = 2), ", ",
        format(round(res$hr_ci[2], 2), nsmall = 2), ")"
      ),
      pvalue = if (res$pvalue < 0.0001) "<0.0001" else format(round(res$pvalue, 4), 4),
      stringsAsFactors = FALSE
    )
    colnames(res_df) <- c("HR", vapply(res[c("hr_ci", "pvalue")], obj_label, FUN.VALUE = "character"))
    row.names(res_df) <- comp
    res_df
  }, comp_group)
  do.call(rbind, results)
}

#' Helper Function: CoxPH Grob
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Grob of `rtable` output from [h_tbl_coxph_pairwise]
#'
#' @inheritParams h_grob_median_surv
#' @param ... arguments will be passed to [h_tbl_coxph_pairwise()].
#' @param x a `numeric` value between 0 and 1 specifying x-location.
#' @param y a `numeric` value between 0 and 1 specifying y-location.
#' @export
#'
#' @examples
#' \dontrun{
#' library(dplyr)
#' library(survival)
#' library(grid)
#'
#' grid::grid.newpage()
#' grid.rect(gp = grid::gpar(lty = 1, col = "pink", fill = "gray85", lwd = 1))
#' data <- tern_ex_adtte %>%
#'   filter(PARAMCD == "OS") %>%
#'   mutate(is_event = CNSR == 0)
#' tbl_grob <- h_grob_coxph(
#'   df = data,
#'   variables = list(tte = "AVAL", is_event = "is_event", arm = "ARMCD"),
#'   control_coxph_pw = control_coxph(conf_level = 0.9), x = 0.5, y = 0.5
#' )
#' grid::grid.draw(tbl_grob)
#' }
h_grob_coxph <- function(...,
                         x = 0,
                         y = 0,
                         ttheme = gridExtra::ttheme_default(
                           base_size = 12,
                           padding = grid::unit(c(1, .5), "lines"),
                           core = list(bg_params = list(fill = c("grey95", "grey90"), alpha = .5))
                         )) {
  data <- h_tbl_coxph_pairwise(...)
  tryCatch(
    expr = {
      gt <- gridExtra::tableGrob(d = data, theme = ttheme) # ERROR 'data' must be of a vector type, was 'NULL'
      vp <- grid::viewport(
        x = grid::unit(x, "npc") + grid::unit(1, "lines"),
        y = grid::unit(y, "npc") + grid::unit(1.5, "lines"),
        height = sum(gt$heights),
        width = sum(gt$widths),
        just = c("left", "bottom")
      )
      grid::gList(
        grid::gTree(
          vp = vp,
          children = grid::gList(gt)
        )
      )
    },
    error = function(w) {
      message(paste(
        "Warning: Cox table will not be displayed as there is",
        "not any level to be compared in the arm variable."
      ))
      return(
        grid::gList(
          grid::gTree(
            vp = NULL,
            children = NULL
          )
        )
      )
    }
  )
}

#' Occurrence Counts by Grade
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Functions for analyzing frequencies and fractions of occurrences by grade for patients
#' with occurrence data. Multiple occurrences within one individual are counted once at the
#' greatest intensity/highest grade level.
#'
#' @inheritParams argument_convention
#' @param grade_groups (named `list` of `character`)\cr containing groupings of grades.
#' @param remove_single (`logical`)\cr `TRUE` to not include the elements of one-element grade groups
#' in the the output list; in this case only the grade groups names will be included in the output.
#'
#' @seealso Relevant helper function [h_append_grade_groups()].
#'
#' @name count_occurrences_by_grade
#'
NULL

#' Helper function for [s_count_occurrences_by_grade()]
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Helper function for [s_count_occurrences_by_grade()] to insert grade groupings into list with
#' individual grade frequencies. The order of the final result follows the order of `grade_groups`.
#' The elements under any-grade group (if any), i.e. the grade group equal to `refs` will be moved to
#' the end. Grade groups names must be unique.
#'
#' @inheritParams count_occurrences_by_grade
#' @param refs (named `list` of `numeric`)\cr where each name corresponds to a reference grade level
#'   and each entry represents a count.
#'
#' @examples
#' h_append_grade_groups(
#'   list(
#'     "Any Grade" = as.character(1:5),
#'     "Grade 1-2" = c("1", "2"),
#'     "Grade 3-4" = c("3", "4")
#'   ),
#'   list("1" = 10, "2" = 20, "3" = 30, "4" = 40, "5" = 50)
#' )
#'
#' h_append_grade_groups(
#'   list(
#'     "Any Grade" = as.character(5:1),
#'     "Grade A" = "5",
#'     "Grade B" = c("4", "3")
#'   ),
#'   list("1" = 10, "2" = 20, "3" = 30, "4" = 40, "5" = 50)
#' )
#'
#' h_append_grade_groups(
#'   list(
#'     "Any Grade" = as.character(1:5),
#'     "Grade 1-2" = c("1", "2"),
#'     "Grade 3-4" = c("3", "4")
#'   ),
#'   list("1" = 10, "2" = 5, "3" = 0)
#' )
#'
#' @export
h_append_grade_groups <- function(grade_groups, refs, remove_single = TRUE) {
  checkmate::assert_list(grade_groups)
  checkmate::assert_list(refs)
  refs_orig <- refs
  elements <- unique(unlist(grade_groups))

  ### compute sums in groups
  grp_sum <- lapply(grade_groups, function(i) do.call(sum, refs[i]))
  if (!checkmate::test_subset(elements, names(refs))) {
    padding_el <- setdiff(elements, names(refs))
    refs[padding_el] <- 0
  }
  result <- c(grp_sum, refs)

  ### order result while keeping grade_groups's ordering
  ordr <- grade_groups

  # elements of any-grade group (if any) will be moved to the end
  is_any <- sapply(grade_groups, setequal, y = names(refs))
  ordr[is_any] <- list(character(0)) # hide elements under any-grade group

  # groups-elements combined sequence
  ordr <- c(lapply(names(ordr), function(g) c(g, ordr[[g]])), recursive = TRUE, use.names = FALSE)
  ordr <- ordr[!duplicated(ordr)]

  # append remaining elements (if any)
  ordr <- union(ordr, unlist(grade_groups[is_any])) # from any-grade group
  ordr <- union(ordr, names(refs)) # from refs

  # remove elements of single-element groups, if any
  if (remove_single) {
    is_single <- sapply(grade_groups, length) == 1L
    ordr <- setdiff(ordr, unlist(grade_groups[is_single]))
  }

  # apply the order
  result <- result[ordr]

  # remove groups without any elements in the original refs
  # note: it's OK if groups have 0 value
  keep_grp <- vapply(grade_groups, function(x, rf) {
    any(x %in% rf)
  }, rf = names(refs_orig), logical(1))

  keep_el <- names(result) %in% names(refs_orig) | names(result) %in% names(keep_grp)[keep_grp]
  result <- result[keep_el]

  result
}

#' @describeIn count_occurrences_by_grade Statistics function which given occurrence data counts the
#'  number of patients by highest grade. Returns a list of counts and fractions with one element
#'  per grade level or grade level grouping.
#'
#' @examples
#' library(dplyr)
#' df <- data.frame(
#'   USUBJID = as.character(c(1:6, 1)),
#'   ARM = factor(c("A", "A", "A", "B", "B", "B", "A"), levels = c("A", "B")),
#'   AETOXGR = factor(c(1, 2, 3, 4, 1, 2, 3), levels = c(1:5)),
#'   AESEV = factor(
#'     x = c("MILD", "MODERATE", "SEVERE", "MILD", "MILD", "MODERATE", "SEVERE"),
#'     levels = c("MILD", "MODERATE", "SEVERE")
#'   ),
#'   stringsAsFactors = FALSE
#' )
#' df_adsl <- df %>%
#'   select(USUBJID, ARM) %>%
#'   unique()
#'
#' s_count_occurrences_by_grade(
#'   df,
#'   .N_col = 10L, # nolint
#'   .var = "AETOXGR",
#'   id = "USUBJID",
#'   grade_groups = list("ANY" = levels(df$AETOXGR))
#' )
#'
#' @export
s_count_occurrences_by_grade <- function(df,
                                         .var,
                                         .N_col, # nolint
                                         id = "USUBJID",
                                         grade_groups = list(),
                                         remove_single = TRUE,
                                         labelstr = "") {
  assert_valid_factor(df[[.var]])
  assert_df_with_variables(df, list(grade = .var, id = id))

  if (nrow(df) < 1) {
    grade_levels <- levels(df[[.var]])
    l_count <- as.list(rep(0, length(grade_levels)))
    names(l_count) <- grade_levels
  } else {
    if (isTRUE(is.factor(df[[id]]))) {
      assert_valid_factor(df[[id]], any.missing = FALSE)
    } else {
      checkmate::assert_character(df[[id]], min.chars = 1, any.missing = FALSE)
    }
    checkmate::assert_count(.N_col)

    id <- df[[id]]
    grade <- df[[.var]]

    if (!is.ordered(grade)) {
      grade_lbl <- obj_label(grade)
      lvls <- levels(grade)
      if (sum(grepl("^\\d+$", lvls)) %in% c(0, length(lvls))) {
        lvl_ord <- lvls
      } else {
        lvls[!grepl("^\\d+$", lvls)] <- min(as.numeric(lvls[grepl("^\\d+$", lvls)])) - 1
        lvl_ord <- levels(grade)[order(as.numeric(lvls))]
      }
      grade <- formatters::with_label(factor(grade, levels = lvl_ord, ordered = TRUE), grade_lbl)
    }

    df_max <- stats::aggregate(grade ~ id, FUN = max, drop = FALSE)
    l_count <- as.list(table(df_max$grade))
  }

  if (length(grade_groups) > 0) {
    l_count <- h_append_grade_groups(grade_groups, l_count, remove_single)
  }

  l_count_fraction <- lapply(l_count, function(i, denom) c(i, i / denom), denom = .N_col)

  list(
    count_fraction = l_count_fraction
  )
}

#' @describeIn count_occurrences_by_grade Formatted Analysis function which can be further customized by calling
#'   [rtables::make_afun()] on it. It is used as `afun` in [rtables::analyze()].
#' @export
#'
#' @examples
#' #  We need to ungroup `count_fraction` first so that the `rtables` formatting
#' # function `format_count_fraction()` can be applied correctly.
#' afun <- make_afun(a_count_occurrences_by_grade, .ungroup_stats = "count_fraction")
#' afun(
#'   df,
#'   .N_col = 10L, # nolint
#'   .var = "AETOXGR",
#'   id = "USUBJID",
#'   grade_groups = list("ANY" = levels(df$AETOXGR))
#' )
a_count_occurrences_by_grade <- make_afun(
  s_count_occurrences_by_grade,
  .formats = c("count_fraction" = format_count_fraction_fixed_dp)
)


#' @describeIn count_occurrences_by_grade Layout creating function which can be used for creating tables,
#'   which can take statistics function arguments and additional format arguments (see below).
#' @param var_labels (`character`)\cr labels to show in the result table.
#' @export
#' @examples
#'
#' # Layout creating function with custom format.
#' basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   add_colcounts() %>%
#'   count_occurrences_by_grade(
#'     var = "AESEV",
#'     .formats = c("count_fraction" = "xx.xx (xx.xx%)")
#'   ) %>%
#'   build_table(df, alt_counts_df = df_adsl)
#'
#' # Define additional grade groupings.
#' grade_groups <- list(
#'   "-Any-" = c("1", "2", "3", "4", "5"),
#'   "Grade 1-2" = c("1", "2"),
#'   "Grade 3-5" = c("3", "4", "5")
#' )
#'
#' basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   add_colcounts() %>%
#'   count_occurrences_by_grade(
#'     var = "AETOXGR",
#'     grade_groups = grade_groups
#'   ) %>%
#'   build_table(df, alt_counts_df = df_adsl)
count_occurrences_by_grade <- function(lyt,
                                       var,
                                       var_labels = var,
                                       show_labels = "default",
                                       ...,
                                       table_names = var,
                                       .stats = NULL,
                                       .formats = NULL,
                                       .indent_mods = NULL,
                                       .labels = NULL) {
  afun <- make_afun(
    a_count_occurrences_by_grade,
    .stats = .stats,
    .formats = .formats,
    .indent_mods = .indent_mods,
    .ungroup_stats = "count_fraction"
  )

  analyze(
    lyt = lyt,
    vars = var,
    var_labels = var_labels,
    show_labels = show_labels,
    afun = afun,
    table_names = table_names,
    extra_args = list(...)
  )
}

#' @describeIn count_occurrences_by_grade Layout creating function which adds content rows using the
#'   statistics function and additional format arguments (see below).
#' @export
#' @examples
#'
#' # Layout creating function with custom format.
#' basic_table() %>%
#'   add_colcounts() %>%
#'   split_rows_by("ARM", child_labels = "visible", nested = TRUE) %>%
#'   summarize_occurrences_by_grade(
#'     var = "AESEV",
#'     .formats = c("count_fraction" = "xx.xx (xx.xx%)")
#'   ) %>%
#'   build_table(df, alt_counts_df = df_adsl)
#'
#' basic_table() %>%
#'   add_colcounts() %>%
#'   split_rows_by("ARM", child_labels = "visible", nested = TRUE) %>%
#'   summarize_occurrences_by_grade(
#'     var = "AETOXGR",
#'     grade_groups = grade_groups
#'   ) %>%
#'   build_table(df, alt_counts_df = df_adsl)
summarize_occurrences_by_grade <- function(lyt,
                                           var,
                                           ...,
                                           .stats = NULL,
                                           .formats = NULL,
                                           .indent_mods = NULL,
                                           .labels = NULL) {
  cfun <- make_afun(
    a_count_occurrences_by_grade,
    .stats = .stats,
    .formats = .formats,
    .labels = .labels,
    .indent_mods = .indent_mods,
    .ungroup_stats = "count_fraction"
  )

  summarize_row_groups(
    lyt = lyt,
    var = var,
    cfun = cfun,
    extra_args = list(...)
  )
}

#' Confidence Intervals for a Difference of Binomials
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Several confidence intervals for the difference between proportions.
#'
#' @param grp (`factor`)\cr vector assigning observations to one out of two groups
#'   (e.g. reference and treatment group).
#'
#' @name desctools_binom

NULL

#' Recycle list of parameters
#'
#' @describeIn desctools_binom This function recycles all supplied elements to the maximal dimension.
#'
#' @keywords internal
h_recycle <- function(...) {
  lst <- list(...)
  maxdim <- max(lengths(lst))
  res <- lapply(lst, rep, length.out = maxdim)
  attr(res, "maxdim") <- maxdim
  return(res)
}

#' @describeIn desctools_binom Several Confidence Intervals for the difference between proportions.
#'
#' @return A named list of 3 values:
#' \describe{
#'   \item{est}{estimate of proportion difference.}
#'   \item{lwrci}{estimate of lower end of the confidence interval.}
#'   \item{upci}{estimate of upper end of the confidence interval.}
#' }
#'
#' @examples
#' # Internal function - desctools_binom
#' \dontrun{
#' set.seed(2)
#' rsp <- sample(c(TRUE, FALSE), replace = TRUE, size = 20)
#' grp <- factor(c(rep("A", 10), rep("B", 10)))
#' tbl <- table(grp, factor(rsp, levels = c(TRUE, FALSE)))
#' desctools_binom(
#'   tbl[1], sum(tbl[1], tbl[3]), tbl[2], sum(tbl[2], tbl[4]),
#'   conf.level = 0.90, method = "waldcc"
#' )
#' }
#'
#' @keywords internal
desctools_binom <- function(x1, n1, x2, n2, conf.level = 0.95, sides = c( # nolint
                              "two.sided",
                              "left", "right"
                            ), method = c(
                              "ac", "wald", "waldcc", "score",
                              "scorecc", "mn", "mee", "blj", "ha", "hal", "jp"
                            )) {
  if (missing(sides)) {
    sides <- match.arg(sides)
  }
  if (missing(method)) {
    method <- match.arg(method)
  }
  iBinomDiffCI <- function(x1, n1, x2, n2, conf.level, sides, # nolint
                           method) {
    if (sides != "two.sided") {
      conf.level <- 1 - 2 * (1 - conf.level) # nolint
    }
    alpha <- 1 - conf.level
    kappa <- stats::qnorm(1 - alpha / 2)
    p1_hat <- x1 / n1
    p2_hat <- x2 / n2
    est <- p1_hat - p2_hat
    switch(method,
      wald = {
        vd <- p1_hat * (1 - p1_hat) / n1 + p2_hat * (1 - p2_hat) / n2
        term2 <- kappa * sqrt(vd)
        ci_lwr <- max(-1, est - term2)
        ci_upr <- min(1, est + term2)
      },
      waldcc = {
        vd <- p1_hat * (1 - p1_hat) / n1 + p2_hat * (1 - p2_hat) / n2
        term2 <- kappa * sqrt(vd)
        term2 <- term2 + 0.5 * (1 / n1 + 1 / n2)
        ci_lwr <- max(-1, est - term2)
        ci_upr <- min(1, est + term2)
      },
      ac = {
        n1 <- n1 + 2
        n2 <- n2 + 2
        x1 <- x1 + 1
        x2 <- x2 + 1
        p1_hat <- x1 / n1
        p2_hat <- x2 / n2
        est1 <- p1_hat - p2_hat
        vd <- p1_hat * (1 - p1_hat) / n1 + p2_hat * (1 - p2_hat) / n2
        term2 <- kappa * sqrt(vd)
        ci_lwr <- max(-1, est1 - term2)
        ci_upr <- min(1, est1 + term2)
      },
      exact = {
        ci_lwr <- NA
        ci_upr <- NA
      },
      score = {
        w1 <- desctools_binomci(
          x = x1, n = n1, conf.level = conf.level,
          method = "wilson"
        )
        w2 <- desctools_binomci(
          x = x2, n = n2, conf.level = conf.level,
          method = "wilson"
        )
        l1 <- w1[2]
        u1 <- w1[3]
        l2 <- w2[2]
        u2 <- w2[3]
        ci_lwr <- est - kappa * sqrt(l1 * (1 - l1) / n1 +
          u2 * (1 - u2) / n2)
        ci_upr <- est + kappa * sqrt(u1 * (1 - u1) / n1 +
          l2 * (1 - l2) / n2)
      },
      scorecc = {
        w1 <- desctools_binomci(
          x = x1, n = n1, conf.level = conf.level,
          method = "wilsoncc"
        )
        w2 <- desctools_binomci(
          x = x2, n = n2, conf.level = conf.level,
          method = "wilsoncc"
        )
        l1 <- w1[2]
        u1 <- w1[3]
        l2 <- w2[2]
        u2 <- w2[3]
        ci_lwr <- max(-1, est - sqrt((p1_hat - l1)^2 +
          (u2 - p2_hat)^2))
        ci_upr <- min(1, est + sqrt((u1 - p1_hat)^2 + (p2_hat -
          l2)^2))
      },
      mee = {
        .score <- function(p1, n1, p2, n2, dif) {
          if (dif > 1) dif <- 1
          if (dif < -1) dif <- -1
          diff <- p1 - p2 - dif
          if (abs(diff) == 0) {
            res <- 0
          } else {
            t <- n2 / n1
            a <- 1 + t
            b <- -(1 + t + p1 + t * p2 + dif * (t + 2))
            c <- dif * dif + dif * (2 * p1 + t + 1) + p1 +
              t * p2
            d <- -p1 * dif * (1 + dif)
            v <- (b / a / 3)^3 - b * c / (6 * a * a) + d / a / 2
            if (abs(v) < .Machine$double.eps) v <- 0
            s <- sqrt((b / a / 3)^2 - c / a / 3)
            u <- ifelse(v > 0, 1, -1) * s
            w <- (3.141592654 + acos(v / u^3)) / 3
            p1d <- 2 * u * cos(w) - b / a / 3
            p2d <- p1d - dif
            n <- n1 + n2
            res <- (p1d * (1 - p1d) / n1 + p2d * (1 - p2d) / n2)
          }
          return(sqrt(res))
        }
        pval <- function(delta) {
          z <- (est - delta) / .score(
            p1_hat, n1, p2_hat,
            n2, delta
          )
          2 * min(stats::pnorm(z), 1 - stats::pnorm(z))
        }
        ci_lwr <- max(-1, stats::uniroot(function(delta) {
          pval(delta) -
            alpha
        }, interval = c(-1 + 1e-06, est - 1e-06))$root)
        ci_upr <- min(1, stats::uniroot(function(delta) {
          pval(delta) -
            alpha
        }, interval = c(est + 1e-06, 1 - 1e-06))$root)
      },
      blj = {
        p1_dash <- (x1 + 0.5) / (n1 + 1)
        p2_dash <- (x2 + 0.5) / (n2 + 1)
        vd <- p1_dash * (1 - p1_dash) / n1 + p2_dash * (1 -
          p2_dash) / n2
        term2 <- kappa * sqrt(vd)
        est_dash <- p1_dash - p2_dash
        ci_lwr <- max(-1, est_dash - term2)
        ci_upr <- min(1, est_dash + term2)
      },
      ha = {
        term2 <- 1 / (2 * min(n1, n2)) + kappa * sqrt(p1_hat *
          (1 - p1_hat) / (n1 - 1) + p2_hat * (1 - p2_hat) / (n2 -
            1))
        ci_lwr <- max(-1, est - term2)
        ci_upr <- min(1, est + term2)
      },
      mn = {
        .conf <- function(x1, n1, x2, n2, z, lower = FALSE) {
          p1 <- x1 / n1
          p2 <- x2 / n2
          p_hat <- p1 - p2
          dp <- 1 + ifelse(lower, 1, -1) * p_hat
          i <- 1
          while (i <= 50) {
            dp <- 0.5 * dp
            y <- p_hat + ifelse(lower, -1, 1) * dp
            score <- .score(p1, n1, p2, n2, y)
            if (score < z) {
              p_hat <- y
            }
            if ((dp < 1e-07) || (abs(z - score) < 1e-06)) {
              (break)()
            } else {
              i <- i +
                1
            }
          }
          return(y)
        }
        .score <- function(p1, n1, p2, n2, dif) {
          diff <- p1 - p2 - dif
          if (abs(diff) == 0) {
            res <- 0
          } else {
            t <- n2 / n1
            a <- 1 + t
            b <- -(1 + t + p1 + t * p2 + dif * (t + 2))
            c <- dif * dif + dif * (2 * p1 + t + 1) + p1 +
              t * p2
            d <- -p1 * dif * (1 + dif)
            v <- (b / a / 3)^3 - b * c / (6 * a * a) + d / a / 2
            s <- sqrt((b / a / 3)^2 - c / a / 3)
            u <- ifelse(v > 0, 1, -1) * s
            w <- (3.141592654 + acos(v / u^3)) / 3
            p1d <- 2 * u * cos(w) - b / a / 3
            p2d <- p1d - dif
            n <- n1 + n2
            var <- (p1d * (1 - p1d) / n1 + p2d * (1 - p2d) / n2) *
              n / (n - 1)
            res <- diff^2 / var
          }
          return(res)
        }
        z <- stats::qchisq(conf.level, 1)
        ci_lwr <- max(-1, .conf(x1, n1, x2, n2, z, TRUE))
        ci_upr <- min(1, .conf(x1, n1, x2, n2, z, FALSE))
      },
      beal = {
        a <- p1_hat + p2_hat
        b <- p1_hat - p2_hat
        u <- ((1 / n1) + (1 / n2)) / 4
        v <- ((1 / n1) - (1 / n2)) / 4
        V <- u * ((2 - a) * a - b^2) + 2 * v * (1 - a) * b # nolint
        z <- stats::qchisq(p = 1 - alpha / 2, df = 1)
        A <- sqrt(z * (V + z * u^2 * (2 - a) * a + z * v^2 * (1 - a)^2)) # nolint
        B <- (b + z * v * (1 - a)) / (1 + z * u) # nolint
        ci_lwr <- max(-1, B - A / (1 + z * u))
        ci_upr <- min(1, B + A / (1 + z * u))
      },
      hal = {
        psi <- (p1_hat + p2_hat) / 2
        u <- (1 / n1 + 1 / n2) / 4
        v <- (1 / n1 - 1 / n2) / 4
        z <- kappa
        theta <- ((p1_hat - p2_hat) + z^2 * v * (1 - 2 *
          psi)) / (1 + z^2 * u)
        w <- z / (1 + z^2 * u) * sqrt(u * (4 * psi * (1 - psi) -
          (p1_hat - p2_hat)^2) + 2 * v * (1 - 2 * psi) *
          (p1_hat - p2_hat) + 4 * z^2 * u^2 * (1 - psi) *
          psi + z^2 * v^2 * (1 - 2 * psi)^2)
        c(theta + w, theta - w)
        ci_lwr <- max(-1, theta - w)
        ci_upr <- min(1, theta + w)
      },
      jp = {
        psi <- 0.5 * ((x1 + 0.5) / (n1 + 1) + (x2 + 0.5) / (n2 +
          1))
        u <- (1 / n1 + 1 / n2) / 4
        v <- (1 / n1 - 1 / n2) / 4
        z <- kappa
        theta <- ((p1_hat - p2_hat) + z^2 * v * (1 - 2 *
          psi)) / (1 + z^2 * u)
        w <- z / (1 + z^2 * u) * sqrt(u * (4 * psi * (1 - psi) -
          (p1_hat - p2_hat)^2) + 2 * v * (1 - 2 * psi) *
          (p1_hat - p2_hat) + 4 * z^2 * u^2 * (1 - psi) *
          psi + z^2 * v^2 * (1 - 2 * psi)^2)
        c(theta + w, theta - w)
        ci_lwr <- max(-1, theta - w)
        ci_upr <- min(1, theta + w)
      },
    )
    ci <- c(
      est = est, lwr.ci = min(ci_lwr, ci_upr),
      upr.ci = max(ci_lwr, ci_upr)
    )
    if (sides == "left") {
      ci[3] <- 1
    } else if (sides == "right") {
      ci[2] <- -1
    }
    return(ci)
  }
  method <- match.arg(arg = method, several.ok = TRUE)
  sides <- match.arg(arg = sides, several.ok = TRUE)
  lst <- h_recycle(
    x1 = x1, n1 = n1, x2 = x2, n2 = n2, conf.level = conf.level,
    sides = sides, method = method
  )
  res <- t(sapply(1:attr(lst, "maxdim"), function(i) {
    iBinomDiffCI(
      x1 = lst$x1[i],
      n1 = lst$n1[i], x2 = lst$x2[i], n2 = lst$n2[i], conf.level = lst$conf.level[i],
      sides = lst$sides[i], method = lst$method[i]
    )
  }))
  lgn <- h_recycle(x1 = if (is.null(names(x1))) {
    paste("x1", seq_along(x1), sep = ".")
  } else {
    names(x1)
  }, n1 = if (is.null(names(n1))) {
    paste("n1", seq_along(n1), sep = ".")
  } else {
    names(n1)
  }, x2 = if (is.null(names(x2))) {
    paste("x2", seq_along(x2), sep = ".")
  } else {
    names(x2)
  }, n2 = if (is.null(names(n2))) {
    paste("n2", seq_along(n2), sep = ".")
  } else {
    names(n2)
  }, conf.level = conf.level, sides = sides, method = method)
  xn <- apply(as.data.frame(lgn[sapply(lgn, function(x) {
    length(unique(x)) !=
      1
  })]), 1, paste, collapse = ":")
  rownames(res) <- xn
  return(res)
}

#' @describeIn desctools_binom Compute confidence intervals for binomial proportions.
#'
#' @param x (`count`)\cr number of successes
#' @param n (`count`)\cr number of trials
#' @param conf.level (`proportion`)\cr confidence level, defaults to 0.95.
#' @param sides (`character`)\cr side of the confidence interval to compute. Must be one of "two-sided" (default),
#'   "left", or "right".
#' @param method (`character`)\cr method to use. Can be one out of: "wald", "wilson", "wilsoncc", "agresti-coull",
#'   "jeffreys", "modified wilson", "modified jeffreys", "clopper-pearson", "arcsine", "logit", "witting", "pratt",
#'   "midp", "lik", and "blaker".
#' @return A matrix with 3 columns containing:
#' \describe{
#'   \item{est}{estimate of proportion difference.}
#'   \item{lwrci}{lower end of the confidence interval.}
#'   \item{upci}{upper end of the confidence interval.}
#' }
#'
#' @keywords internal
desctools_binomci <- function(x,
                              n,
                              conf.level = 0.95, # nolint
                              sides = c("two.sided", "left", "right"),
                              method = c(
                                "wilson", "wald", "waldcc", "agresti-coull",
                                "jeffreys", "modified wilson", "wilsoncc", "modified jeffreys",
                                "clopper-pearson", "arcsine", "logit", "witting", "pratt",
                                "midp", "lik", "blaker"
                              ),
                              rand = 123,
                              tol = 1e-05) {
  if (missing(method)) {
    method <- "wilson"
  }
  if (missing(sides)) {
    sides <- "two.sided"
  }
  iBinomCI <- function(x, n, conf.level = 0.95, sides = c( # nolint
                         "two.sided",
                         "left", "right"
                       ), method = c(
                         "wilson", "wilsoncc", "wald",
                         "waldcc", "agresti-coull", "jeffreys", "modified wilson",
                         "modified jeffreys", "clopper-pearson", "arcsine", "logit",
                         "witting", "pratt", "midp", "lik", "blaker"
                       ), rand = 123,
                       tol = 1e-05) {
    if (length(x) != 1) {
      stop("'x' has to be of length 1 (number of successes)")
    }
    if (length(n) != 1) {
      stop("'n' has to be of length 1 (number of trials)")
    }
    if (length(conf.level) != 1) {
      stop("'conf.level' has to be of length 1 (confidence level)")
    }
    if (conf.level < 0.5 || conf.level > 1) {
      stop("'conf.level' has to be in [0.5, 1]")
    }
    sides <- match.arg(sides, choices = c(
      "two.sided", "left",
      "right"
    ), several.ok = FALSE)
    if (sides != "two.sided") {
      conf.level <- 1 - 2 * (1 - conf.level) # nolint
    }
    alpha <- 1 - conf.level
    kappa <- stats::qnorm(1 - alpha / 2)
    p_hat <- x / n
    q_hat <- 1 - p_hat
    est <- p_hat
    switch(match.arg(arg = method, choices = c(
      "wilson",
      "wald", "waldcc", "wilsoncc", "agresti-coull", "jeffreys",
      "modified wilson", "modified jeffreys", "clopper-pearson",
      "arcsine", "logit", "witting", "pratt", "midp", "lik",
      "blaker"
    )),
    wald = {
      term2 <- kappa * sqrt(p_hat * q_hat) / sqrt(n)
      ci_lwr <- max(0, p_hat - term2)
      ci_upr <- min(1, p_hat + term2)
    },
    waldcc = {
      term2 <- kappa * sqrt(p_hat * q_hat) / sqrt(n)
      term2 <- term2 + 1 / (2 * n)
      ci_lwr <- max(0, p_hat - term2)
      ci_upr <- min(1, p_hat + term2)
    },
    wilson = {
      term1 <- (x + kappa^2 / 2) / (n + kappa^2)
      term2 <- kappa * sqrt(n) / (n + kappa^2) * sqrt(p_hat *
        q_hat + kappa^2 / (4 * n))
      ci_lwr <- max(0, term1 - term2)
      ci_upr <- min(1, term1 + term2)
    },
    wilsoncc = {
      lci <- (2 * x + kappa^2 - 1 - kappa * sqrt(kappa^2 -
        2 - 1 / n + 4 * p_hat * (n * q_hat + 1))) / (2 *
        (n + kappa^2))
      uci <- (2 * x + kappa^2 + 1 + kappa * sqrt(kappa^2 +
        2 - 1 / n + 4 * p_hat * (n * q_hat - 1))) / (2 *
        (n + kappa^2))
      ci_lwr <- max(0, ifelse(p_hat == 0, 0, lci))
      ci_upr <- min(1, ifelse(p_hat == 1, 1, uci))
    },
    `agresti-coull` = {
      x_tilde <- x + kappa^2 / 2
      n_tilde <- n + kappa^2
      p_tilde <- x_tilde / n_tilde
      q_tilde <- 1 - p_tilde
      est <- p_tilde
      term2 <- kappa * sqrt(p_tilde * q_tilde) / sqrt(n_tilde)
      ci_lwr <- max(0, p_tilde - term2)
      ci_upr <- min(1, p_tilde + term2)
    },
    jeffreys = {
      if (x == 0) {
        ci_lwr <- 0
      } else {
        ci_lwr <- stats::qbeta(
          alpha / 2,
          x + 0.5, n - x + 0.5
        )
      }
      if (x == n) {
        ci_upr <- 1
      } else {
        ci_upr <- stats::qbeta(1 -
          alpha / 2, x + 0.5, n - x + 0.5)
      }
    },
    `modified wilson` = {
      term1 <- (x + kappa^2 / 2) / (n + kappa^2)
      term2 <- kappa * sqrt(n) / (n + kappa^2) * sqrt(p_hat *
        q_hat + kappa^2 / (4 * n))
      if ((n <= 50 & x %in% c(1, 2)) | (n >= 51 & x %in%
        c(1:3))) {
        ci_lwr <- 0.5 * stats::qchisq(alpha, 2 *
          x) / n
      } else {
        ci_lwr <- max(0, term1 - term2)
      }
      if ((n <= 50 & x %in% c(n - 1, n - 2)) | (n >= 51 &
        x %in% c(n - (1:3)))) {
        ci_upr <- 1 - 0.5 * stats::qchisq(
          alpha,
          2 * (n - x)
        ) / n
      } else {
        ci_upr <- min(1, term1 +
          term2)
      }
    },
    `modified jeffreys` = {
      if (x == n) {
        ci_lwr <- (alpha / 2)^(1 / n)
      } else {
        if (x <= 1) {
          ci_lwr <- 0
        } else {
          ci_lwr <- stats::qbeta(
            alpha / 2,
            x + 0.5, n - x + 0.5
          )
        }
      }
      if (x == 0) {
        ci_upr <- 1 - (alpha / 2)^(1 / n)
      } else {
        if (x >= n - 1) {
          ci_upr <- 1
        } else {
          ci_upr <- stats::qbeta(1 -
            alpha / 2, x + 0.5, n - x + 0.5)
        }
      }
    },
    `clopper-pearson` = {
      ci_lwr <- stats::qbeta(alpha / 2, x, n - x + 1)
      ci_upr <- stats::qbeta(1 - alpha / 2, x + 1, n - x)
    },
    arcsine = {
      p_tilde <- (x + 0.375) / (n + 0.75)
      est <- p_tilde
      ci_lwr <- sin(asin(sqrt(p_tilde)) - 0.5 * kappa / sqrt(n))^2
      ci_upr <- sin(asin(sqrt(p_tilde)) + 0.5 * kappa / sqrt(n))^2
    },
    logit = {
      lambda_hat <- log(x / (n - x))
      V_hat <- n / (x * (n - x)) # nolint
      lambda_lower <- lambda_hat - kappa * sqrt(V_hat)
      lambda_upper <- lambda_hat + kappa * sqrt(V_hat)
      ci_lwr <- exp(lambda_lower) / (1 + exp(lambda_lower))
      ci_upr <- exp(lambda_upper) / (1 + exp(lambda_upper))
    },
    witting = {
      set.seed(rand)
      x_tilde <- x + stats::runif(1, min = 0, max = 1)
      pbinom_abscont <- function(q, size, prob) {
        v <- trunc(q)
        term1 <- stats::pbinom(v - 1, size = size, prob = prob)
        term2 <- (q - v) * stats::dbinom(v, size = size, prob = prob)
        return(term1 + term2)
      }
      qbinom_abscont <- function(p, size, x) {
        fun <- function(prob, size, x, p) {
          pbinom_abscont(x, size, prob) - p
        }
        stats::uniroot(fun,
          interval = c(0, 1), size = size,
          x = x, p = p
        )$root
      }
      ci_lwr <- qbinom_abscont(1 - alpha, size = n, x = x_tilde)
      ci_upr <- qbinom_abscont(alpha, size = n, x = x_tilde)
    },
    pratt = {
      if (x == 0) {
        ci_lwr <- 0
        ci_upr <- 1 - alpha^(1 / n)
      } else if (x == 1) {
        ci_lwr <- 1 - (1 - alpha / 2)^(1 / n)
        ci_upr <- 1 - (alpha / 2)^(1 / n)
      } else if (x == (n - 1)) {
        ci_lwr <- (alpha / 2)^(1 / n)
        ci_upr <- (1 - alpha / 2)^(1 / n)
      } else if (x == n) {
        ci_lwr <- alpha^(1 / n)
        ci_upr <- 1
      } else {
        z <- stats::qnorm(1 - alpha / 2)
        A <- ((x + 1) / (n - x))^2 # nolint
        B <- 81 * (x + 1) * (n - x) - 9 * n - 8 # nolint
        C <- (0 - 3) * z * sqrt(9 * (x + 1) * (n - x) * (9 * n + 5 - z^2) + n + 1) # nolint
        D <- 81 * (x + 1)^2 - 9 * (x + 1) * (2 + z^2) + 1 # nolint
        E <- 1 + A * ((B + C) / D)^3 # nolint
        ci_upr <- 1 / E
        A <- (x / (n - x - 1))^2 # nolint
        B <- 81 * x * (n - x - 1) - 9 * n - 8 # nolint
        C <- 3 * z * sqrt(9 * x * (n - x - 1) * (9 * n + 5 - z^2) + n + 1) # nolint
        D <- 81 * x^2 - 9 * x * (2 + z^2) + 1 # nolint
        E <- 1 + A * ((B + C) / D)^3 # nolint
        ci_lwr <- 1 / E
      }
    },
    midp = {
      f_low <- function(pi, x, n) {
        1 / 2 * stats::dbinom(x, size = n, prob = pi) + stats::pbinom(x,
          size = n, prob = pi, lower.tail = FALSE
        ) -
          (1 - conf.level) / 2
      }
      f_up <- function(pi, x, n) {
        1 / 2 * stats::dbinom(x, size = n, prob = pi) + stats::pbinom(x -
          1, size = n, prob = pi) - (1 - conf.level) / 2
      }
      ci_lwr <- 0
      ci_upr <- 1
      if (x != 0) {
        ci_lwr <- stats::uniroot(f_low,
          interval = c(0, p_hat),
          x = x, n = n
        )$root
      }
      if (x != n) {
        ci_upr <- stats::uniroot(f_up, interval = c(
          p_hat,
          1
        ), x = x, n = n)$root
      }
    },
    lik = {
      ci_lwr <- 0
      ci_upr <- 1
      z <- stats::qnorm(1 - alpha * 0.5)
      tol <- .Machine$double.eps^0.5
      BinDev <- function(y, x, mu, wt, bound = 0, tol = .Machine$double.eps^0.5, # nolint
                         ...) {
        ll_y <- ifelse(y %in% c(0, 1), 0, stats::dbinom(x, wt,
          y,
          log = TRUE
        ))
        ll_mu <- ifelse(mu %in% c(0, 1), 0, stats::dbinom(x,
          wt, mu,
          log = TRUE
        ))
        res <- ifelse(abs(y - mu) < tol, 0, sign(y -
          mu) * sqrt(-2 * (ll_y - ll_mu)))
        return(res - bound)
      }
      if (x != 0 && tol < p_hat) {
        ci_lwr <- if (BinDev(
          tol, x, p_hat, n, -z,
          tol
        ) <= 0) {
          stats::uniroot(
            f = BinDev, interval = c(tol, if (p_hat <
              tol || p_hat == 1) {
              1 - tol
            } else {
              p_hat
            }), bound = -z,
            x = x, mu = p_hat, wt = n
          )$root
        }
      }
      if (x != n && p_hat < (1 - tol)) {
        ci_upr <- if (BinDev(y = 1 - tol, x = x, mu = ifelse(p_hat >
          1 - tol, tol, p_hat), wt = n, bound = z, tol = tol) <
          0) {
          ci_lwr <- if (BinDev(
            tol, x, if (p_hat <
              tol || p_hat == 1) {
              1 - tol
            } else {
              p_hat
            }, n,
            -z, tol
          ) <= 0) {
            stats::uniroot(
              f = BinDev, interval = c(tol, p_hat),
              bound = -z, x = x, mu = p_hat, wt = n
            )$root
          }
        } else {
          stats::uniroot(
            f = BinDev, interval = c(if (p_hat >
              1 - tol) {
              tol
            } else {
              p_hat
            }, 1 - tol), bound = z,
            x = x, mu = p_hat, wt = n
          )$root
        }
      }
    },
    blaker = {
      acceptbin <- function(x, n, p) {
        p1 <- 1 - stats::pbinom(x - 1, n, p)
        p2 <- stats::pbinom(x, n, p)
        a1 <- p1 + stats::pbinom(stats::qbinom(p1, n, p) - 1, n, p)
        a2 <- p2 + 1 - stats::pbinom(
          stats::qbinom(1 - p2, n, p), n,
          p
        )
        return(min(a1, a2))
      }
      ci_lwr <- 0
      ci_upr <- 1
      if (x != 0) {
        ci_lwr <- stats::qbeta((1 - conf.level) / 2, x, n -
          x + 1)
        while (acceptbin(x, n, ci_lwr + tol) < (1 -
          conf.level)) {
          ci_lwr <- ci_lwr + tol
        }
      }
      if (x != n) {
        ci_upr <- stats::qbeta(1 - (1 - conf.level) / 2, x +
          1, n - x)
        while (acceptbin(x, n, ci_upr - tol) < (1 -
          conf.level)) {
          ci_upr <- ci_upr - tol
        }
      }
    }
    )
    ci <- c(est = est, lwr.ci = max(0, ci_lwr), upr.ci = min(
      1,
      ci_upr
    ))
    if (sides == "left") {
      ci[3] <- 1
    } else if (sides == "right") {
      ci[2] <- 0
    }
    return(ci)
  }
  lst <- list(
    x = x, n = n, conf.level = conf.level, sides = sides,
    method = method, rand = rand
  )
  maxdim <- max(unlist(lapply(lst, length)))
  lgp <- lapply(lst, rep, length.out = maxdim)
  lgn <- h_recycle(x = if (is.null(names(x))) {
    paste("x", seq_along(x), sep = ".")
  } else {
    names(x)
  }, n = if (is.null(names(n))) {
    paste("n", seq_along(n), sep = ".")
  } else {
    names(n)
  }, conf.level = conf.level, sides = sides, method = method)
  xn <- apply(as.data.frame(lgn[sapply(lgn, function(x) {
    length(unique(x)) !=
      1
  })]), 1, paste, collapse = ":")
  res <- t(sapply(1:maxdim, function(i) {
    iBinomCI( # nolint
      x = lgp$x[i],
      n = lgp$n[i], conf.level = lgp$conf.level[i], sides = lgp$sides[i],
      method = lgp$method[i], rand = lgp$rand[i]
    )
  }))
  colnames(res)[1] <- c("est")
  rownames(res) <- xn
  return(res)
}

#' Helper Functions for Cox Proportional Hazards Regression
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Helper functions used in [fit_coxreg_univar()] and [fit_coxreg_multivar()].
#'
#' @inheritParams argument_convention
#' @seealso [cox_regression]
#'
#' @name h_cox_regression
NULL

#' @describeIn h_cox_regression Helper for Cox Regression Formula
#'
#' Creates a list of formulas. It is used internally by [fit_coxreg_univar()]
#' for the comparison of univariate Cox regression models.
#'
#' @inheritParams argument_convention
#' @inheritParams control_coxreg
#'
#' @return
#' The function `h_coxreg_univar_formulas` returns a `character` vector coercible
#' into formulas (e.g [stats::as.formula()]).
#'
#' @examples
#' # `h_coxreg_univar_formulas`
#'
#' ## Simple formulas.
#' h_coxreg_univar_formulas(
#'   variables = list(
#'     time = "time", event = "status", arm = "armcd", covariates = c("X", "y")
#'   )
#' )
#'
#' ## Addition of an optional strata.
#' h_coxreg_univar_formulas(
#'   variables = list(
#'     time = "time", event = "status", arm = "armcd", covariates = c("X", "y"),
#'     strata = "SITE"
#'   )
#' )
#'
#' ## Inclusion of the interaction term.
#' h_coxreg_univar_formulas(
#'   variables = list(
#'     time = "time", event = "status", arm = "armcd", covariates = c("X", "y"),
#'     strata = "SITE"
#'   ),
#'   interaction = TRUE
#' )
#'
#' ## Only covariates fitted in separate models.
#' h_coxreg_univar_formulas(
#'   variables = list(
#'     time = "time", event = "status", covariates = c("X", "y")
#'   )
#' )
#'
#' @export
h_coxreg_univar_formulas <- function(variables,
                                     interaction = FALSE) {
  checkmate::assert_list(variables, names = "named")
  has_arm <- "arm" %in% names(variables)
  arm_name <- if (has_arm) "arm" else NULL

  checkmate::assert_character(variables$covariates, null.ok = TRUE)

  checkmate::assert_flag(interaction)

  if (!has_arm || is.null(variables$covariates)) {
    checkmate::assert_false(interaction)
  }

  assert_list_of_variables(variables[c(arm_name, "event", "time")])

  if (!is.null(variables$covariates)) {
    forms <- paste0(
      "survival::Surv(", variables$time, ", ", variables$event, ") ~ ",
      ifelse(has_arm, variables$arm, "1"),
      ifelse(interaction, " * ", " + "),
      variables$covariates,
      ifelse(
        !is.null(variables$strata),
        paste0(" + strata(", paste0(variables$strata, collapse = ", "), ")"),
        ""
      )
    )
  } else {
    forms <- NULL
  }
  nams <- variables$covariates
  if (has_arm) {
    ref <- paste0(
      "survival::Surv(", variables$time, ", ", variables$event, ") ~ ",
      variables$arm,
      ifelse(
        !is.null(variables$strata),
        paste0(
          " + strata(", paste0(variables$strata, collapse = ", "), ")"
        ),
        ""
      )
    )
    forms <- c(ref, forms)
    nams <- c("ref", nams)
  }
  stats::setNames(forms, nams)
}

#' @describeIn h_cox_regression Helper for Multi-variable Cox Regression Formula
#'
#' Creates a formulas string. It is used internally by [fit_coxreg_multivar()]
#' for the comparison of multi-variable Cox regression models. Interactions will not
#' be included in multi-variable Cox regression model.
#'
#' @inheritParams argument_convention
#'
#' @return
#' The function `h_coxreg_univar_formulas` returns a `character` vector coercible
#' into formulas (e.g [stats::as.formula()]).
#'
#' @export
#'
#' @examples
#' # `h_coxreg_multivar_formula`
#'
#' h_coxreg_multivar_formula(
#'   variables = list(
#'     time = "AVAL", event = "event", arm = "ARMCD", covariates = c("RACE", "AGE")
#'   )
#' )
#'
#' # Addition of an optional strata.
#' h_coxreg_multivar_formula(
#'   variables = list(
#'     time = "AVAL", event = "event", arm = "ARMCD", covariates = c("RACE", "AGE"),
#'     strata = "SITE"
#'   )
#' )
#'
#' # Example without treatment arm.
#' h_coxreg_multivar_formula(
#'   variables = list(
#'     time = "AVAL", event = "event", covariates = c("RACE", "AGE"),
#'     strata = "SITE"
#'   )
#' )
h_coxreg_multivar_formula <- function(variables) {
  checkmate::assert_list(variables, names = "named")
  has_arm <- "arm" %in% names(variables)
  arm_name <- if (has_arm) "arm" else NULL

  checkmate::assert_character(variables$covariates, null.ok = TRUE)

  assert_list_of_variables(variables[c(arm_name, "event", "time")])

  y <- paste0(
    "survival::Surv(", variables$time, ", ", variables$event, ") ~ ",
    ifelse(has_arm, variables$arm, "1")
  )
  if (length(variables$covariates) > 0) {
    y <- paste(y, paste(variables$covariates, collapse = " + "), sep = " + ")
  }
  if (!is.null(variables$strata)) {
    y <- paste0(y, " + strata(", paste0(variables$strata, collapse = ", "), ")")
  }
  y
}

#' @describeIn h_cox_regression Utility function to help tabulate the result of
#' a univariate Cox regression model.
#'
#' @inheritParams argument_convention
#' @inheritParams cox_regression_inter
#' @param effect (`string`)\cr the treatment variable.
#' @param mod (`coxph`)\cr Cox regression model fitted by [survival::coxph()].
#'
#' @examples
#' library(survival)
#'
#' dta_simple <- data.frame(
#'   time = c(5, 5, 10, 10, 5, 5, 10, 10),
#'   status = c(0, 0, 1, 0, 0, 1, 1, 1),
#'   armcd = factor(LETTERS[c(1, 1, 1, 1, 2, 2, 2, 2)], levels = c("A", "B")),
#'   var1 = c(45, 55, 65, 75, 55, 65, 85, 75),
#'   var2 = c("F", "M", "F", "M", "F", "M", "F", "U")
#' )
#' mod <- coxph(Surv(time, status) ~ armcd + var1, data = dta_simple)
#' result <- h_coxreg_univar_extract(
#'   effect = "armcd", covar = "armcd", mod = mod, data = dta_simple
#' )
#' result
#'
#' @export
h_coxreg_univar_extract <- function(effect,
                                    covar,
                                    data,
                                    mod,
                                    control = control_coxreg()) {
  checkmate::assert_string(covar)
  checkmate::assert_string(effect)
  checkmate::assert_class(mod, "coxph")
  test_statistic <- c(wald = "Wald", likelihood = "LR")[control$pval_method]

  mod_aov <- muffled_car_anova(mod, test_statistic)
  msum <- summary(mod, conf.int = control$conf_level)
  sum_cox <- broom::tidy(msum)

  # Combine results together.
  effect_aov <- mod_aov[effect, , drop = TRUE]
  pval <- effect_aov[[grep(pattern = "Pr", x = names(effect_aov)), drop = TRUE]]
  sum_main <- sum_cox[grepl(effect, sum_cox$level), ]

  term_label <- if (effect == covar) {
    paste0(
      levels(data[[covar]])[2],
      " vs control (",
      levels(data[[covar]])[1],
      ")"
    )
  } else {
    unname(labels_or_names(data[covar]))
  }
  data.frame(
    effect = ifelse(covar == effect, "Treatment:", "Covariate:"),
    term = covar,
    term_label = term_label,
    level = levels(data[[effect]])[2],
    n = mod[["n"]],
    hr = unname(sum_main["exp(coef)"]),
    lcl = unname(sum_main[grep("lower", names(sum_main))]),
    ucl = unname(sum_main[grep("upper", names(sum_main))]),
    pval = pval,
    stringsAsFactors = FALSE
  )
}

#' @describeIn h_cox_regression Tabulation of Multi-variable Cox Regressions
#'
#' Utility function to help tabulate the result of a multi-variable Cox regression model
#' for a treatment/covariate variable.
#'
#' @inheritParams argument_convention
#' @inheritParams h_coxreg_univar_extract
#' @export
#'
#' @examples
#' mod <- coxph(Surv(time, status) ~ armcd + var1, data = dta_simple)
#' result <- h_coxreg_multivar_extract(
#'   var = "var1", mod = mod, data = dta_simple
#' )
#' result
h_coxreg_multivar_extract <- function(var,
                                      data,
                                      mod,
                                      control = control_coxreg()) {
  test_statistic <- c(wald = "Wald", likelihood = "LR")[control$pval_method]
  mod_aov <- muffled_car_anova(mod, test_statistic)

  msum <- summary(mod, conf.int = control$conf_level)
  sum_anova <- broom::tidy(mod_aov)
  sum_cox <- broom::tidy(msum)

  ret_anova <- sum_anova[sum_anova$term == var, c("term", "p.value")]
  names(ret_anova)[2] <- "pval"
  if (is.factor(data[[var]])) {
    ret_cox <- sum_cox[startsWith(prefix = var, x = sum_cox$level), !(names(sum_cox) %in% "exp(-coef)")]
  } else {
    ret_cox <- sum_cox[(var == sum_cox$level), !(names(sum_cox) %in% "exp(-coef)")]
  }
  names(ret_cox)[1:4] <- c("pval", "hr", "lcl", "ucl")
  varlab <- unname(labels_or_names(data[var]))
  ret_cox$term <- varlab

  if (is.numeric(data[[var]])) {
    ret <- ret_cox
    ret$term_label <- ret$term
  } else if (length(levels(data[[var]])) <= 2) {
    ret_anova$pval <- NA
    ret_anova$term_label <- paste0(varlab, " (reference = ", levels(data[[var]])[1], ")")
    ret_cox$level <- gsub(var, "", ret_cox$level)
    ret_cox$term_label <- ret_cox$level
    ret <- dplyr::bind_rows(ret_anova, ret_cox)
  } else {
    ret_anova$term_label <- paste0(varlab, " (reference = ", levels(data[[var]])[1], ")")
    ret_cox$level <- gsub(var, "", ret_cox$level)
    ret_cox$term_label <- ret_cox$level
    ret <- dplyr::bind_rows(ret_anova, ret_cox)
  }

  as.data.frame(ret)
}

#' Patient Counts for Laboratory Events (Worsen From Baseline) by Highest Grade Post-Baseline
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Patient count and fraction for laboratory events (worsen from baseline) shift table.
#'
#' @inheritParams argument_convention
#'
#' @seealso Relevant helper functions [h_adlb_worsen()] and [h_worsen_counter()].
#'
#' @name abnormal_by_worst_grade_worsen
NULL

#' Helper Function to Prepare ADLB with Worst Labs
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Helper function to prepare a `df` for generate the patient count shift table
#'
#' @param adlb (`data.frame`)\cr `ADLB` dataframe
#' @param worst_flag_low (named `vector`)\cr Worst low post-baseline lab grade flag variable
#' @param worst_flag_high (named `vector`)\cr Worst high post-baseline lab grade flag variable
#' @param direction_var (`string`)\cr Direction variable specifying the direction of the shift table of interest.
#'   Only lab records flagged by `L`, `H` or `B` are included in the shift table.
#'   * `L`: low direction only
#'   * `H`: high direction only
#'   * `B`: both low and high directions
#'
#' @return [h_adlb_worsen()] returns the `adlb` `data.frame` containing only the
#'   worst labs specified according to `worst_flag_low` or `worst_flag_high` for the
#'   direction specified according to `direction_var`. For instance, for a lab that is
#'   needed for the low direction only, only records flagged by `worst_flag_low` are
#'   selected. For a lab that is needed for both low and high directions, the worst
#'   low records are selected for the low direction, and the worst high record are selected
#'   for the high direction.
#' @seealso [abnormal_by_worst_grade_worsen]
#'
#' @examples
#' library(dplyr)
#'
#' # The direction variable, GRADDR, is based on metadata
#' adlb <- tern_ex_adlb %>%
#'   mutate(
#'     GRADDR = case_when(
#'       PARAMCD == "ALT" ~ "B",
#'       PARAMCD == "CRP" ~ "L",
#'       PARAMCD == "IGA" ~ "H"
#'     )
#'   ) %>%
#'   filter(SAFFL == "Y" & ONTRTFL == "Y" & GRADDR != "")
#'
#' df <- h_adlb_worsen(
#'   adlb,
#'   worst_flag_low = c("WGRLOFL" = "Y"),
#'   worst_flag_high = c("WGRHIFL" = "Y"),
#'   direction_var = "GRADDR"
#' )
#'
#' @export
h_adlb_worsen <- function(adlb,
                          worst_flag_low = NULL,
                          worst_flag_high = NULL,
                          direction_var) {
  checkmate::assert_string(direction_var)
  checkmate::assert_subset(as.character(unique(adlb[[direction_var]])), c("B", "L", "H"))
  assert_df_with_variables(adlb, list("Col" = direction_var))

  if (any(unique(adlb[[direction_var]]) == "H")) {
    assert_df_with_variables(adlb, list("High" = names(worst_flag_high)))
  }

  if (any(unique(adlb[[direction_var]]) == "L")) {
    assert_df_with_variables(adlb, list("Low" = names(worst_flag_low)))
  }

  if (any(unique(adlb[[direction_var]]) == "B")) {
    assert_df_with_variables(
      adlb,
      list(
        "Low" = names(worst_flag_low),
        "High" = names(worst_flag_high)
      )
    )
  }

  # extract patients with worst post-baseline lab, either low or high or both
  worst_flag <- c(worst_flag_low, worst_flag_high)
  col_names <- names(worst_flag)
  filter_values <- worst_flag
  temp <- Map(
    function(x, y) which(adlb[[x]] == y),
    col_names,
    filter_values
  )
  position_satisfy_filters <- Reduce(union, temp)

  # select variables of interest
  adlb_f <- adlb[position_satisfy_filters, ]

  # generate subsets for different directionality
  adlb_f_h <- adlb_f[which(adlb_f[[direction_var]] == "H"), ]
  adlb_f_l <- adlb_f[which(adlb_f[[direction_var]] == "L"), ]
  adlb_f_b <- adlb_f[which(adlb_f[[direction_var]] == "B"), ]

  # for labs requiring both high and low, data is duplicated and will be stacked on top of each other
  adlb_f_b_h <- adlb_f_b
  adlb_f_b_l <- adlb_f_b

  # extract data with worst lab
  if (!is.null(worst_flag_high) && !is.null(worst_flag_low)) {
    # change H to High, L to Low
    adlb_f_h[[direction_var]] <- rep("High", nrow(adlb_f_h))
    adlb_f_l[[direction_var]] <- rep("Low", nrow(adlb_f_l))

    # change, B to High and Low
    adlb_f_b_h[[direction_var]] <- rep("High", nrow(adlb_f_b_h))
    adlb_f_b_l[[direction_var]] <- rep("Low", nrow(adlb_f_b_l))

    adlb_out_h <- adlb_f_h[which(adlb_f_h[[names(worst_flag_high)]] == worst_flag_high), ]
    adlb_out_b_h <- adlb_f_b_h[which(adlb_f_b_h[[names(worst_flag_high)]] == worst_flag_high), ]
    adlb_out_l <- adlb_f_l[which(adlb_f_l[[names(worst_flag_low)]] == worst_flag_low), ]
    adlb_out_b_l <- adlb_f_b_l[which(adlb_f_b_l[[names(worst_flag_low)]] == worst_flag_low), ]

    out <- rbind(adlb_out_h, adlb_out_b_h, adlb_out_l, adlb_out_b_l)
  } else if (!is.null(worst_flag_high)) {
    adlb_f_h[[direction_var]] <- rep("High", nrow(adlb_f_h))
    adlb_f_b_h[[direction_var]] <- rep("High", nrow(adlb_f_b_h))

    adlb_out_h <- adlb_f_h[which(adlb_f_h[[names(worst_flag_high)]] == worst_flag_high), ]
    adlb_out_b_h <- adlb_f_b_h[which(adlb_f_b_h[[names(worst_flag_high)]] == worst_flag_high), ]

    out <- rbind(adlb_out_h, adlb_out_b_h)
  } else if (!is.null(worst_flag_low)) {
    adlb_f_l[[direction_var]] <- rep("Low", nrow(adlb_f_l))
    adlb_f_b_l[[direction_var]] <- rep("Low", nrow(adlb_f_b_l))

    adlb_out_l <- adlb_f_l[which(adlb_f_l[[names(worst_flag_low)]] == worst_flag_low), ]
    adlb_out_b_l <- adlb_f_b_l[which(adlb_f_b_l[[names(worst_flag_low)]] == worst_flag_low), ]

    out <- rbind(adlb_out_l, adlb_out_b_l)
  }

  # label
  formatters::var_labels(out) <- formatters::var_labels(adlb_f, fill = FALSE)
  # NA
  out
}

#' Helper Function to Analyze Patients for [s_count_abnormal_lab_worsen_by_baseline()]
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Helper function to count the number of patients and the fraction of patients according to
#' highest post-baseline lab grade variable `.var`, baseline lab grade variable `baseline_var`,
#' and the direction of interest specified in `direction_var`.
#'
#' @inheritParams argument_convention
#' @inheritParams h_adlb_worsen
#' @param baseline_var (`string`)\cr baseline lab grade variable
#' @return [h_worsen_counter()] returns the counts and fraction of patients
#'   whose worst post-baseline lab grades are worse than their baseline grades, for
#'   post-baseline worst grades "1", "2", "3", "4" and "Any".
#' @seealso [abnormal_by_worst_grade_worsen]
#'
#' @examples
#' library(dplyr)
#'
#' # The direction variable, GRADDR, is based on metadata
#' adlb <- tern_ex_adlb %>%
#'   mutate(
#'     GRADDR = case_when(
#'       PARAMCD == "ALT" ~ "B",
#'       PARAMCD == "CRP" ~ "L",
#'       PARAMCD == "IGA" ~ "H"
#'     )
#'   ) %>%
#'   filter(SAFFL == "Y" & ONTRTFL == "Y" & GRADDR != "")
#'
#' df <- h_adlb_worsen(
#'   adlb,
#'   worst_flag_low = c("WGRLOFL" = "Y"),
#'   worst_flag_high = c("WGRHIFL" = "Y"),
#'   direction_var = "GRADDR"
#' )
#'
#' # `h_worsen_counter`
#' h_worsen_counter(
#'   df %>% filter(PARAMCD == "CRP" & GRADDR == "Low"),
#'   id = "USUBJID",
#'   .var = "ATOXGR",
#'   baseline_var = "BTOXGR",
#'   direction_var = "GRADDR"
#' )
#'
#' @export
h_worsen_counter <- function(df, id, .var, baseline_var, direction_var) {
  checkmate::assert_string(id)
  checkmate::assert_string(.var)
  checkmate::assert_string(baseline_var)
  checkmate::assert_scalar(unique(df[[direction_var]]))
  checkmate::assert_subset(unique(df[[direction_var]]), c("High", "Low"))
  assert_df_with_variables(df, list(val = c(id, .var, baseline_var, direction_var)))

  # remove post-baseline missing
  df <- df[df[[.var]] != "<Missing>", ]

  # obtain directionality
  direction <- unique(df[[direction_var]])

  if (direction == "Low") {
    grade <- -1:-4
    worst_grade <- -4
  } else if (direction == "High") {
    grade <- 1:4
    worst_grade <- 4
  }

  if (nrow(df) > 0) {
    by_grade <- lapply(grade, function(i) {
      # filter baseline values that is less than i or <Missing>
      df_temp <- df[df[[baseline_var]] %in% c((i + sign(i) * -1):(-1 * worst_grade), "<Missing>"), ]
      # num: number of patients with post-baseline worst lab equal to i
      num <- length(unique(df_temp[df_temp[[.var]] %in% i, id, drop = TRUE]))
      # denom: number of patients with baseline values less than i or <missing> and post-baseline in the same direction
      denom <- length(unique(df_temp[[id]]))
      rm(df_temp)
      c(num = num, denom = denom)
    })
  } else {
    by_grade <- lapply(1, function(i) {
      c(num = 0, denom = 0)
    })
  }

  names(by_grade) <- as.character(seq_along(by_grade))

  # baseline grade less 4 or missing
  df_temp <- df[!df[[baseline_var]] %in% worst_grade, ]

  # denom: number of patients with baseline values less than 4 or <missing> and post-baseline in the same direction
  denom <- length(unique(df_temp[, id, drop = TRUE]))

  # condition 1: missing baseline and in the direction of abnormality
  con1 <- which(df_temp[[baseline_var]] == "<Missing>" & df_temp[[.var]] %in% grade)
  df_temp_nm <- df_temp[which(df_temp[[baseline_var]] != "<Missing>" & df_temp[[.var]] %in% grade), ]

  # condition 2: if post-baseline values are present then post-baseline values must be worse than baseline
  if (direction == "Low") {
    con2 <- which(as.numeric(as.character(df_temp_nm[[.var]])) < as.numeric(as.character(df_temp_nm[[baseline_var]])))
  } else {
    con2 <- which(as.numeric(as.character(df_temp_nm[[.var]])) > as.numeric(as.character(df_temp_nm[[baseline_var]])))
  }

  # number of patients satisfy either conditions 1 or 2
  num <- length(unique(df_temp[union(con1, con2), id, drop = TRUE]))

  list(fraction = c(by_grade, list("Any" = c(num = num, denom = denom))))
}

#' @describeIn abnormal_by_worst_grade_worsen Statistics function which calculates the
#'   counts and fraction of patients whose worst post-baseline lab grades are worse than
#'   their baseline grades, for post-baseline worst grades "1", "2", "3", "4" and "Any".
#'
#' @param variables (named `list` of `string`)\cr list of additional analysis variables including:
#'   * `id` (`string`)\cr subject variable name.
#'   * `baseline_var` (`string`)\cr name of the data column containing baseline toxicity variable.
#'   * `direction_var` (`string`)\cr see `direction_var` for more details.
#' @return [s_count_abnormal_lab_worsen_by_baseline()] returns the
#'   counts and fraction of patients whose worst post-baseline lab grades are worse than
#'   their baseline grades, for post-baseline worst grades "1", "2", "3", "4" and "Any".
#'
#' @examples
#' library(dplyr)
#'
#' # The direction variable, GRADDR, is based on metadata
#' adlb <- tern_ex_adlb %>%
#'   mutate(
#'     GRADDR = case_when(
#'       PARAMCD == "ALT" ~ "B",
#'       PARAMCD == "CRP" ~ "L",
#'       PARAMCD == "IGA" ~ "H"
#'     )
#'   ) %>%
#'   filter(SAFFL == "Y" & ONTRTFL == "Y" & GRADDR != "")
#'
#' df <- h_adlb_worsen(
#'   adlb,
#'   worst_flag_low = c("WGRLOFL" = "Y"),
#'   worst_flag_high = c("WGRHIFL" = "Y"),
#'   direction_var = "GRADDR"
#' )
#' # Internal function - s_count_abnormal_lab_worsen_by_baseline
#' \dontrun{
#' # Patients with worsening lab grade for CRP in the direction of low
#' s_count_abnormal_lab_worsen_by_baseline(
#'   df = df %>% filter(ARMCD == "ARM A" & PARAMCD == "CRP"),
#'   .var = "ATOXGR",
#'   variables = list(
#'     id = "USUBJID",
#'     baseline_var = "BTOXGR",
#'     direction_var = "GRADDR"
#'   )
#' )
#' }
#'
#' @keywords internal
s_count_abnormal_lab_worsen_by_baseline <- function(df, # nolint
                                                    .var = "ATOXGR",
                                                    variables = list(
                                                      id = "USUBJID",
                                                      baseline_var = "BTOXGR",
                                                      direction_var = "GRADDR"
                                                    )) {
  checkmate::assert_string(.var)
  checkmate::assert_set_equal(names(variables), c("id", "baseline_var", "direction_var"))
  checkmate::assert_string(variables$id)
  checkmate::assert_string(variables$baseline_var)
  checkmate::assert_string(variables$direction_var)
  assert_df_with_variables(df, c(aval = .var, variables[1:3]))
  assert_list_of_variables(variables)

  h_worsen_counter(df, variables$id, .var, variables$baseline_var, variables$direction_var)
}


#' @describeIn abnormal_by_worst_grade_worsen
#'
#' @return [a_count_abnormal_lab_worsen_by_baseline()] returns the corresponding list with
#'   formatted [rtables::CellValue()].
#'
#' @examples
#' # Internal function - a_count_abnormal_lab_worsen_by_baseline
#' \dontrun{
#' a_count_abnormal_lab_worsen_by_baseline(
#'   df = df %>% filter(ARMCD == "ARM A" & PARAMCD == "CRP"),
#'   .var = "ATOXGR",
#'   variables = list(id = "USUBJID", baseline_var = "BTOXGR", direction_var = "GRADDR")
#' )
#' }
#'
#' @keywords internal
a_count_abnormal_lab_worsen_by_baseline <- make_afun( # nolint
  s_count_abnormal_lab_worsen_by_baseline,
  .formats = c(fraction = format_fraction),
  .ungroup_stats = "fraction"
)

#' @describeIn abnormal_by_worst_grade_worsen Layout creating function which can be used for creating tables,
#'   which can take statistics function arguments and additional format arguments (see below).
#'
#' @examples
#' basic_table() %>%
#'   split_cols_by("ARMCD") %>%
#'   add_colcounts() %>%
#'   split_rows_by("PARAMCD") %>%
#'   split_rows_by("GRADDR") %>%
#'   count_abnormal_lab_worsen_by_baseline(
#'     var = "ATOXGR",
#'     variables = list(
#'       id = "USUBJID",
#'       baseline_var = "BTOXGR",
#'       direction_var = "GRADDR"
#'     )
#'   ) %>%
#'   append_topleft("Direction of Abnormality") %>%
#'   build_table(df = df, alt_counts_df = tern_ex_adsl)
#'
#' @export
count_abnormal_lab_worsen_by_baseline <- function(lyt, # nolint
                                                  var,
                                                  ...,
                                                  table_names = NULL,
                                                  .stats = NULL,
                                                  .formats = NULL,
                                                  .labels = NULL,
                                                  .indent_mods = NULL) {
  checkmate::assert_string(var)

  afun <- make_afun(
    a_count_abnormal_lab_worsen_by_baseline,
    .stats = .stats,
    .formats = .formats,
    .labels = .labels,
    .indent_mods = .indent_mods
  )

  lyt <- analyze(
    lyt = lyt,
    vars = var,
    afun = afun,
    extra_args = list(...),
    show_labels = "hidden"
  )

  lyt
}

#' Additional Assertions for `checkmate`
#'
#' @description
#' Additional assertion functions which can be used together with the `checkmate` package.
#'
#' @param x (`any`)\cr object to test.
#' @param df (`data.frame`)\cr data set to test.
#' @param variables (named `list` of `character`)\cr list of variables to test.
#' @param include_boundaries (`logical`)\cr whether to include boundaries when testing
#'   for proportions.
#' @param na_level (`character`)\cr the string you have been using to represent NA or
#'   missing data. For `NA` values please consider using directly `base::is.na` or
#'   similar approaches.
#' @inheritParams checkmate::assert_factor
#' @param (`integer`)\cr minimum number of factor levels. Default is `1`.
#' @param ... a collection of objects to test.
#' @name assertions
NULL

check_list_of_variables <- function(x) {
  # drop NULL elements in list
  x <- Filter(Negate(is.null), x)

  res <- checkmate::check_list(x,
    names = "named",
    min.len = 1,
    any.missing = FALSE,
    types = "character"
  )
  # no empty strings allowed
  if (isTRUE(res)) {
    res <- checkmate::check_character(unlist(x), min.chars = 1)
  }
  return(res)
}
#' @describeIn assertions Check whether `x` is a valid list of variable names.
#'   `NULL` elements of the list `x` are dropped out with `Filter(Negate(is.null), x)`.
#'
#' @examples
#' # Check whether `x` is a valid list of variable names.
#'
#' # Internal function - assert_list_of_variables
#' \dontrun{
#' assert_list_of_variables(list(val = "a"))
#' assert_list_of_variables(list(val = c("a", "b")))
#' assert_list_of_variables(list(val = c("a", "b"), val2 = NULL))
#'
#' # The following calls fail
#' assert_list_of_variables(list(1, 2))
#' assert_list_of_variables(list("bla" = 2))
#' }
#'
#' @keywords internal
assert_list_of_variables <- checkmate::makeAssertionFunction(check_list_of_variables)

check_df_with_variables <- function(df, variables, na_level = NULL) {
  checkmate::assert_data_frame(df)
  assert_list_of_variables(variables)

  # flag for equal variables and column names
  err_flag <- all(unlist(variables) %in% colnames(df))
  checkmate::assert_flag(err_flag)

  if (isFALSE(err_flag)) {
    vars <- setdiff(unlist(variables), colnames(df))
    return(paste(
      deparse(substitute(df)),
      "does not contain all specified variables as column names. Missing from dataframe:",
      paste(vars, collapse = ", ")
    ))
  }
  # checking if na_level is present and in which column
  if (!is.null(na_level)) {
    checkmate::assert_string(na_level)
    res <- unlist(lapply(as.list(df)[unlist(variables)], function(x) any(x == na_level)))
    if (any(res)) {
      return(paste0(
        deparse(substitute(df)), " contains explicit na_level (", na_level,
        ") in the following columns: ", paste0(unlist(variables)[res],
          collapse = ", "
        )
      ))
    }
  }
  return(TRUE)
}
#' @describeIn assertions Check whether `df` is a data frame with the analysis `variables`.
#'   Please notice how this produces an error when not all variables are present in the
#'   data.frame while the opposite is not required.
#'
#' @examples
#' # Check whether `df` contains the analysis `variables`.
#'
#' # Internal function - assert_df_with_variables
#' \dontrun{
#' assert_df_with_variables(
#'   df = data.frame(a = 5, b = 3),
#'   variables = list(val = "a")
#' )
#' assert_df_with_variables(
#'   df = data.frame(a = 5, b = 3),
#'   variables = list(val = c("a", "b"))
#' )
#' assert_df_with_variables(
#'   df = data.frame(a = 5, b = 3),
#'   variables = list(val = c("a", "b"))
#' )
#' assert_df_with_variables(
#'   df = data.frame(a = 5, b = 3, e = "<Missing>"),
#'   variables = list(val = c("a", "b")), na_level = "<Missing>"
#' )
#'
#' # The following calls fail
#' assert_df_with_variables(
#'   df = matrix(1:5, ncol = 2, nrow = 3),
#'   variables = list(val = "a")
#' )
#' assert_df_with_variables(
#'   df = data.frame(a = 5, b = 3),
#'   variables = list(val = c("a", "b", "c"))
#' )
#' assert_df_with_variables(
#'   df = data.frame(a = 5, b = 3, e = "<Missing>"),
#'   variables = list(val = c("a", "b", "e")), na_level = "<Missing>"
#' )
#' }
#'
#' @keywords internal
assert_df_with_variables <- checkmate::makeAssertionFunction(check_df_with_variables)

check_valid_factor <- function(x,
                               min.levels = 1, # nolint
                               max.levels = NULL, # nolint
                               null.ok = TRUE, # nolint
                               any.missing = TRUE, # nolint
                               n.levels = NULL, # nolint
                               len = NULL) {
  # checks on levels insertion
  checkmate::assert_int(min.levels, lower = 1)

  # main factor check
  res <- checkmate::check_factor(x,
    min.levels = min.levels,
    null.ok = null.ok,
    max.levels = max.levels,
    any.missing = any.missing,
    n.levels = n.levels
  )

  # no empty strings allowed
  if (isTRUE(res)) {
    res <- checkmate::check_character(levels(x), min.chars = 1)
  }

  return(res)
}
#' @describeIn assertions Check whether `x` is a valid factor (has levels and no empty
#'   string levels). Note that `NULL` and `NA` elements are allowed.
#'
#' @examples
#' # Check whether `x` is a valid factor.
#'
#' # Internal function - assert_valid_factor
#' \dontrun{
#' assert_valid_factor(factor(c("a", NULL)))
#' assert_valid_factor(factor(c("a", "b")))
#' assert_valid_factor(factor(c("a", "b")), len = 2)
#' assert_valid_factor(factor(c("a", NA)), any.missing = TRUE)
#' assert_valid_factor(factor("A", levels = c("A", "B")))
#'
#' # The following calls fail
#' assert_valid_factor(-1)
#' assert_valid_factor(factor(c("a", "")))
#' assert_valid_factor(factor(c("a", NA)), any.missing = FALSE)
#' assert_valid_factor(factor(NULL))
#' assert_valid_factor(factor(c(NULL, "")))
#' assert_valid_factor(factor())
#' }
#'
#' @keywords internal
assert_valid_factor <- checkmate::makeAssertionFunction(check_valid_factor)


check_df_with_factors <- function(df,
                                  variables,
                                  min.levels = 1, # nolint
                                  max.levels = NULL, # nolint
                                  any.missing = TRUE, # nolint
                                  na_level = NULL) {
  res <- check_df_with_variables(df, variables, na_level)
  # checking if all the columns specified by variables are valid factors
  if (isTRUE(res)) {
    # searching the data.frame with selected columns (variables) as a list
    res <- lapply(
      X = as.list(df)[unlist(variables)],
      FUN = check_valid_factor,
      min.levels = min.levels,
      max.levels = max.levels,
      any.missing = any.missing
    )
    res_lo <- unlist(vapply(res, Negate(isTRUE), logical(1)))
    if (any(res_lo)) {
      return(paste0(
        deparse(substitute(df)), " does not contain only factor variables among:",
        "\n* Column `", paste0(unlist(variables)[res_lo],
          "` of the data.frame -> ", res[res_lo],
          collapse = "\n* "
        )
      ))
    } else {
      res <- TRUE
    }
  }
  return(res)
}
#' @describeIn assertions Check whether `df` is a data frame where the analysis `variables`
#'   are all factors. Note that the creation of `NA` by direct call of `factor()` will
#'   trim `NA` levels out of the vector list itself.
#'
#' @examples
#' # Check whether `df` contains all factor analysis `variables`.
#' adf <- data.frame(a = factor(c("A", "B")), b = 3)
#' bdf <- data.frame(a = factor(letters[1:3]), b = factor(c(1, 2, 3)), d = 3)
#'
#' # Internal function - assert_df_with_factors
#' \dontrun{
#' assert_df_with_factors(df = adf, variables = list(val = "a"))
#' assert_df_with_factors(df = adf, variables = list(val = "a"), min.levels = 1)
#' assert_df_with_factors(df = adf, variables = list(val = "a"), min.levels = 2, max.levels = 2)
#' assert_df_with_factors(
#'   df = data.frame(a = factor(c("A", NA, "B")), b = 3),
#'   variable = list(val = "a"),
#'   min.levels = 2,
#'   max.levels = 2
#' )
#'
#' # The following calls fail
#' assert_df_with_factors(df = adf, variables = list(val = "a"), min.levels = 1, max.levels = 1)
#' assert_df_with_factors(df = adf, variables = list(val = "a"), min.levels = 1, max.levels = 1)
#' assert_df_with_factors(df = adf, variables = list(val = "a", val = "b", val = ""))
#' assert_df_with_factors(df = adf, variables = list(val = "a", val = "b", val = "d"))
#' assert_df_with_factors(
#'   df = bdf,
#'   variables = list(val = "a", val = "b"),
#'   min.levels = 1,
#'   max.levels = 1
#' )
#' }
#'
#' @keywords internal
assert_df_with_factors <- checkmate::makeAssertionFunction(check_df_with_factors)

#' @describeIn assertions Check whether `x` is a proportion: number between 0 and 1.
#'
#' @examples
#' # Check whether `x` is between 0 and 1.
#' # Internal function - assert_proportion_value
#' \dontrun{
#' assert_proportion_value(x = 0, include_boundaries = TRUE)
#' assert_proportion_value(x = 0.3)
#'
#' # These fail
#' assert_proportion_value(x = 1.3)
#' assert_proportion_value(x = 1)
#' }
#'
#' @keywords internal
assert_proportion_value <- function(x, include_boundaries = FALSE) {
  checkmate::assert_number(x, lower = 0, upper = 1)
  checkmate::assert_flag(include_boundaries)
  if (isFALSE(include_boundaries)) {
    checkmate::assert_true(x > 0)
    checkmate::assert_true(x < 1)
  }
}

#' Helper Functions for Tabulating Binary Response by Subgroup
#'
#' Helper functions that tabulate in a data frame statistics such as response rate
#' and odds ratio for population subgroups.
#'
#' @details Main functionality is to prepare data for use in a layout creating function.
#'
#' @description `r lifecycle::badge("stable")`
#' @inheritParams argument_convention
#' @inheritParams response_subgroups
#' @param arm (`factor`)\cr the treatment group variable.
#' @name h_response_subgroups
#'
#' @examples
#' library(dplyr)
#' library(forcats)
#'
#' adrs <- tern_ex_adrs
#' adrs_labels <- formatters::var_labels(adrs)
#'
#' adrs_f <- adrs %>%
#'   filter(PARAMCD == "BESRSPI") %>%
#'   filter(ARM %in% c("A: Drug X", "B: Placebo")) %>%
#'   droplevels() %>%
#'   mutate(
#'     # Reorder levels of factor to make the placebo group the reference arm.
#'     ARM = fct_relevel(ARM, "B: Placebo"),
#'     rsp = AVALC == "CR"
#'   )
#' formatters::var_labels(adrs_f) <- c(adrs_labels, "Response")
NULL

#' @describeIn h_response_subgroups helper to prepare a data frame of binary responses by arm.
#' @inheritParams h_response_subgroups
#' @export
#' @examples
#'
#' h_proportion_df(
#'   c(TRUE, FALSE, FALSE),
#'   arm = factor(c("A", "A", "B"), levels = c("A", "B"))
#' )
h_proportion_df <- function(rsp, arm) {
  checkmate::assert_logical(rsp)
  assert_valid_factor(arm, len = length(rsp))
  non_missing_rsp <- !is.na(rsp)
  rsp <- rsp[non_missing_rsp]
  arm <- arm[non_missing_rsp]

  lst_rsp <- split(rsp, arm)
  lst_results <- Map(function(x, arm) {
    if (length(x) > 0) {
      s_prop <- s_proportion(df = x)
      data.frame(
        arm = arm,
        n = length(x),
        n_rsp = unname(s_prop$n_prop[1]),
        prop = unname(s_prop$n_prop[2]),
        stringsAsFactors = FALSE
      )
    } else {
      data.frame(
        arm = arm,
        n = 0L,
        n_rsp = NA,
        prop = NA,
        stringsAsFactors = FALSE
      )
    }
  }, lst_rsp, names(lst_rsp))

  df <- do.call(rbind, args = c(lst_results, make.row.names = FALSE))
  df$arm <- factor(df$arm, levels = levels(arm))
  df
}

#' @describeIn h_response_subgroups summarizes proportion of binary responses by arm and across subgroups
#'    in a data frame. `variables` corresponds to the names of variables found in `data`, passed as a named list and
#'    requires elements `rsp`, `arm` and optionally `subgroups`. `groups_lists` optionally specifies
#'    groupings for `subgroups` variables.
#' @export
#'
#' @examples
#' h_proportion_subgroups_df(
#'   variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
#'   data = adrs_f
#' )
#'
#' # Define groupings for BMRKR2 levels.
#' h_proportion_subgroups_df(
#'   variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
#'   data = adrs_f,
#'   groups_lists = list(
#'     BMRKR2 = list(
#'       "low" = "LOW",
#'       "low/medium" = c("LOW", "MEDIUM"),
#'       "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
#'     )
#'   )
#' )
h_proportion_subgroups_df <- function(variables,
                                      data,
                                      groups_lists = list(),
                                      label_all = "All Patients") {
  checkmate::assert_character(variables$rsp)
  checkmate::assert_character(variables$arm)
  checkmate::assert_character(variables$subgroups, null.ok = TRUE)
  assert_df_with_factors(data, list(val = variables$arm), min.levels = 2, max.levels = 2)
  assert_df_with_variables(data, variables)
  checkmate::assert_string(label_all)

  # Add All Patients.
  result_all <- h_proportion_df(data[[variables$rsp]], data[[variables$arm]])
  result_all$subgroup <- label_all
  result_all$var <- "ALL"
  result_all$var_label <- label_all
  result_all$row_type <- "content"

  # Add Subgroups.
  if (is.null(variables$subgroups)) {
    result_all
  } else {
    l_data <- h_split_by_subgroups(data, variables$subgroups, groups_lists = groups_lists)

    l_result <- lapply(l_data, function(grp) {
      result <- h_proportion_df(grp$df[[variables$rsp]], grp$df[[variables$arm]])
      result_labels <- grp$df_labels[rep(1, times = nrow(result)), ]
      cbind(result, result_labels)
    })
    result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE))
    result_subgroups$row_type <- "analysis"

    rbind(
      result_all,
      result_subgroups
    )
  }
}

#' @describeIn h_response_subgroups helper to prepare a data frame with estimates of
#'   the odds ratio between a treatment and a control arm.
#'
#' @inheritParams response_subgroups
#' @param strata_data (`factor`, `data.frame` or `NULL`)\cr required if stratified analysis is performed.
#' @export
#'
#' @examples
#' # Unstratatified analysis.
#' h_odds_ratio_df(
#'   c(TRUE, FALSE, FALSE, TRUE),
#'   arm = factor(c("A", "A", "B", "B"), levels = c("A", "B"))
#' )
#'
#' # Include p-value.
#' h_odds_ratio_df(adrs_f$rsp, adrs_f$ARM, method = "chisq")
#'
#' # Stratatified analysis.
#' h_odds_ratio_df(
#'   rsp = adrs_f$rsp,
#'   arm = adrs_f$ARM,
#'   strata_data = adrs_f[, c("STRATA1", "STRATA2")],
#'   method = "cmh"
#' )
h_odds_ratio_df <- function(rsp, arm, strata_data = NULL, conf_level = 0.95, method = NULL) {
  assert_valid_factor(arm, n.levels = 2, len = length(rsp))

  df_rsp <- data.frame(
    rsp = rsp,
    arm = arm
  )

  if (!is.null(strata_data)) {
    strata_var <- interaction(strata_data, drop = TRUE)
    strata_name <- "strata"

    assert_valid_factor(strata_var, len = nrow(df_rsp))

    df_rsp[[strata_name]] <- strata_var
  } else {
    strata_name <- NULL
  }

  l_df <- split(df_rsp, arm)

  if (nrow(l_df[[1]]) > 0 && nrow(l_df[[2]]) > 0) {
    # Odds ratio and CI.
    result_odds_ratio <- s_odds_ratio(
      df = l_df[[2]],
      .var = "rsp",
      .ref_group = l_df[[1]],
      .in_ref_col = FALSE,
      .df_row = df_rsp,
      variables = list(arm = "arm", strata = strata_name),
      conf_level = conf_level
    )

    df <- data.frame(
      # Dummy column needed downstream to create a nested header.
      arm = " ",
      n_tot = unname(result_odds_ratio$n_tot["n_tot"]),
      or = unname(result_odds_ratio$or_ci["est"]),
      lcl = unname(result_odds_ratio$or_ci["lcl"]),
      ucl = unname(result_odds_ratio$or_ci["ucl"]),
      conf_level = conf_level,
      stringsAsFactors = FALSE
    )

    if (!is.null(method)) {
      # Test for difference.
      result_test <- s_test_proportion_diff(
        df = l_df[[2]],
        .var = "rsp",
        .ref_group = l_df[[1]],
        .in_ref_col = FALSE,
        variables = list(strata = strata_name),
        method = method
      )

      df$pval <- as.numeric(result_test$pval)
      df$pval_label <- obj_label(result_test$pval)
    }

    # In those cases cannot go through the model so will obtain n_tot from data.
  } else if (
    (nrow(l_df[[1]]) == 0 && nrow(l_df[[2]]) > 0) ||
      (nrow(l_df[[1]]) > 0 && nrow(l_df[[2]]) == 0)
  ) {
    df <- data.frame(
      # Dummy column needed downstream to create a nested header.
      arm = " ",
      n_tot = sum(stats::complete.cases(df_rsp)),
      or = NA,
      lcl = NA,
      ucl = NA,
      conf_level = conf_level,
      stringsAsFactors = FALSE
    )
    if (!is.null(method)) {
      df$pval <- NA
      df$pval_label <- NA
    }
  } else {
    df <- data.frame(
      # Dummy column needed downstream to create a nested header.
      arm = " ",
      n_tot = 0L,
      or = NA,
      lcl = NA,
      ucl = NA,
      conf_level = conf_level,
      stringsAsFactors = FALSE
    )

    if (!is.null(method)) {
      df$pval <- NA
      df$pval_label <- NA
    }
  }

  df
}

#' @describeIn h_response_subgroups summarizes estimates of the odds ratio between a treatment and a control
#'   arm across subgroups in a data frame. `variables` corresponds to the names of variables found in
#'   `data`, passed as a named list and requires elements `rsp`, `arm` and optionally `subgroups`
#'   and `strat`. `groups_lists` optionally specifies groupings for `subgroups` variables.
#' @export
#'
#' @examples
#' # Unstratified analysis.
#' h_odds_ratio_subgroups_df(
#'   variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
#'   data = adrs_f
#' )
#'
#' # Stratified analysis.
#' h_odds_ratio_subgroups_df(
#'   variables = list(
#'     rsp = "rsp",
#'     arm = "ARM",
#'     subgroups = c("SEX", "BMRKR2"),
#'     strat = c("STRATA1", "STRATA2")
#'   ),
#'   data = adrs_f
#' )
#'
#' # Define groupings of BMRKR2 levels.
#' h_odds_ratio_subgroups_df(
#'   variables = list(
#'     rsp = "rsp",
#'     arm = "ARM",
#'     subgroups = c("SEX", "BMRKR2")
#'   ),
#'   data = adrs_f,
#'   groups_lists = list(
#'     BMRKR2 = list(
#'       "low" = "LOW",
#'       "low/medium" = c("LOW", "MEDIUM"),
#'       "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
#'     )
#'   )
#' )
h_odds_ratio_subgroups_df <- function(variables,
                                      data,
                                      groups_lists = list(),
                                      conf_level = 0.95,
                                      method = NULL,
                                      label_all = "All Patients") {
  checkmate::assert_character(variables$rsp)
  checkmate::assert_character(variables$arm)
  checkmate::assert_character(variables$subgroups, null.ok = TRUE)
  checkmate::assert_character(variables$strat, null.ok = TRUE)
  assert_df_with_factors(data, list(val = variables$arm), min.levels = 2, max.levels = 2)
  assert_df_with_variables(data, variables)
  checkmate::assert_string(label_all)

  strata_data <- if (is.null(variables$strat)) {
    NULL
  } else {
    data[, variables$strat, drop = FALSE]
  }

  # Add All Patients.
  result_all <- h_odds_ratio_df(
    rsp = data[[variables$rsp]],
    arm = data[[variables$arm]],
    strata_data = strata_data,
    conf_level = conf_level,
    method = method
  )
  result_all$subgroup <- label_all
  result_all$var <- "ALL"
  result_all$var_label <- label_all
  result_all$row_type <- "content"

  if (is.null(variables$subgroups)) {
    result_all
  } else {
    l_data <- h_split_by_subgroups(data, variables$subgroups, groups_lists = groups_lists)

    l_result <- lapply(l_data, function(grp) {
      grp_strata_data <- if (is.null(variables$strat)) {
        NULL
      } else {
        grp$df[, variables$strat, drop = FALSE]
      }

      result <- h_odds_ratio_df(
        rsp = grp$df[[variables$rsp]],
        arm = grp$df[[variables$arm]],
        strata_data = grp_strata_data,
        conf_level = conf_level,
        method = method
      )
      result_labels <- grp$df_labels[rep(1, times = nrow(result)), ]
      cbind(result, result_labels)
    })

    result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE))
    result_subgroups$row_type <- "analysis"

    rbind(
      result_all,
      result_subgroups
    )
  }
}

#' @include summarize_variables.R
NULL

#' Compare Variables Between Groups
#'
#' @description `r lifecycle::badge("stable")`
#'
#' We use the new S3 generic function [s_compare()] to implement comparisons for
#' different `x` objects. This is used as Statistics Function in combination
#' with the new Analyze Function [compare_vars()].
#'
#' @seealso Relevant constructor function [create_afun_compare()].
#'
#' @name compare_variables
#'
NULL

#' @inheritParams argument_convention
#' @describeIn compare_variables `s_compare` is a S3 generic function to produce
#'   an object description and comparison versus the reference column in the form
#'   of p-values.
#' @seealso [s_summary()] which is used internally for the summary part per column.
#'
#' @export
#'
s_compare <- function(x,
                      .ref_group,
                      .in_ref_col,
                      ...) {
  UseMethod("s_compare", x)
}

#' @describeIn compare_variables Method for numeric class. This uses the standard t-test
#'   to calculate the p-value.
#' @return If `x` is of class `numeric`, returns a list with named items:
#'   - all items from [s_summary.numeric()].
#'   - `pval`: the p-value.
#' @method s_compare numeric
#'
#' @export
#'
#' @examples
#' # `s_compare.numeric`
#'
#' ## Usual case where both this and the reference group vector have more than 1 value.
#' s_compare(rnorm(10, 5, 1), .ref_group = rnorm(5, -5, 1), .in_ref_col = FALSE)
#'
#' ## If one group has not more than 1 value, then p-value is not calculated.
#' s_compare(rnorm(10, 5, 1), .ref_group = 1, .in_ref_col = FALSE)
#'
#' ## Empty numeric does not fail, it returns NA-filled items and no p-value.
#' s_compare(numeric(), .ref_group = numeric(), .in_ref_col = FALSE)
s_compare.numeric <- function(x,
                              .ref_group,
                              .in_ref_col,
                              ...) {
  checkmate::assert_numeric(x)
  checkmate::assert_numeric(.ref_group)
  checkmate::assert_flag(.in_ref_col)

  y <- s_summary.numeric(x = x, ...)

  y$pval <- if (!.in_ref_col && n_available(x) > 1 && n_available(.ref_group) > 1) {
    stats::t.test(x, .ref_group)$p.value
  } else {
    character()
  }

  y
}

#' @describeIn compare_variables Method for factor class. This uses the chi-squared test
#'   to calculate the p-value. Note that the `denom` for factor proportions can only be `n` here
#'   since the usage is for comparing proportions between columns.
#'   Therefore a row-based proportion would not make sense. Also proportion based on `N_col` would
#'   be difficult since for the chi-squared test statistic we use the counts. Therefore
#'   missing values should be accounted for explicitly as factor levels.
#' @param denom (`string`)\cr choice of denominator for factor proportions,
#'   can only be `n` (number of values in this row and column intersection).
#' @return If `x` is of class `factor` or converted from `character`, returns a list with named items:
#'   - all items from [s_summary.factor()].
#'   - `pval`: the p-value.
#' @method s_compare factor
#'
#' @export
#'
#' @examples
#' # `s_compare.factor`
#'
#' ## Basic usage:
#' x <- factor(c("a", "a", "b", "c", "a"))
#' y <- factor(c("a", "b", "c"))
#' s_compare(x = x, .ref_group = y, .in_ref_col = FALSE)
#'
#' ## Management of NA values.
#' x <- explicit_na(factor(c("a", "a", "b", "c", "a", NA, NA)))
#' y <- explicit_na(factor(c("a", "b", "c", NA)))
#' s_compare(x = x, .ref_group = y, .in_ref_col = FALSE, na.rm = TRUE)
#' s_compare(x = x, .ref_group = y, .in_ref_col = FALSE, na.rm = FALSE)
s_compare.factor <- function(x,
                             .ref_group,
                             .in_ref_col,
                             denom = "n",
                             na.rm = TRUE, # nolint
                             na_level = "<Missing>",
                             ...) {
  checkmate::assert_flag(.in_ref_col)
  assert_valid_factor(x, any.missing = FALSE)
  assert_valid_factor(.ref_group, any.missing = FALSE)
  denom <- match.arg(denom)

  y <- s_summary.factor(
    x = x,
    denom = denom,
    na.rm = na.rm,
    na_level = na_level,
    ...
  )

  if (na.rm) {
    x <- fct_discard(x, na_level)
    .ref_group <- fct_discard(.ref_group, na_level)
  }

  checkmate::assert_factor(x, levels = levels(.ref_group), min.levels = 2)

  y$pval <- if (!.in_ref_col && length(x) > 0 && length(.ref_group) > 0) {
    tab <- rbind(table(x), table(.ref_group))
    res <- suppressWarnings(stats::chisq.test(tab))
    res$p.value
  } else {
    character()
  }

  y
}

#' @describeIn compare_variables Method for character class. This makes an automatic
#'   conversion to factor (with a warning) and then forwards to the method for factors.
#' @param verbose defaults to `TRUE`. It prints out warnings and messages. It is mainly used
#'   to print out information about factor casting.
#' @note Automatic conversion of character to factor does not guarantee that the table
#'   can be generated correctly. In particular for sparse tables this very likely can fail.
#'   It is therefore better to always pre-process the dataset such that factors are manually
#'   created from character variables before passing the dataset to [rtables::build_table()].
#' @method s_compare character
#'
#' @examples
#' # `s_compare.character`
#'
#' ## Basic usage:
#' x <- c("a", "a", "b", "c", "a")
#' y <- c("a", "b", "c")
#' s_compare(x, .ref_group = y, .in_ref_col = FALSE, .var = "x", verbose = FALSE)
#'
#' ## Note that missing values handling can make a large difference:
#' x <- c("a", "a", "b", "c", "a", NA)
#' y <- c("a", "b", "c", rep(NA, 20))
#' s_compare(x,
#'   .ref_group = y, .in_ref_col = FALSE,
#'   .var = "x", verbose = FALSE
#' )
#' s_compare(x,
#'   .ref_group = y, .in_ref_col = FALSE, .var = "x",
#'   na.rm = FALSE, verbose = FALSE
#' )
#'
#' @export
s_compare.character <- function(x,
                                .ref_group,
                                .in_ref_col,
                                denom = "n",
                                na.rm = TRUE, # nolint
                                na_level = "<Missing>",
                                .var,
                                verbose = TRUE,
                                ...) {
  x <- as_factor_keep_attributes(x, x_name = .var, na_level = na_level, verbose = verbose)
  .ref_group <- as_factor_keep_attributes(.ref_group, x_name = .var, na_level = na_level, verbose = verbose)
  s_compare(
    x = x,
    .ref_group = .ref_group,
    .in_ref_col = .in_ref_col,
    denom = denom,
    na.rm = na.rm,
    na_level = na_level,
    ...
  )
}

#' @describeIn compare_variables Method for logical class. A chi-squared test
#'   is used. If missing values are not removed, then they are counted as `FALSE`.
#' @return If `x` is of class `logical`, returns a list with named items:
#'   - all items from [s_summary.logical()].
#'   - `pval`: the p-value.
#' @method s_compare logical
#'
#' @export
#'
#' @examples
#' # `s_compare.logical`
#'
#' ## Basic usage:
#' x <- c(TRUE, FALSE, TRUE, TRUE)
#' y <- c(FALSE, FALSE, TRUE)
#' s_compare(x, .ref_group = y, .in_ref_col = FALSE)
#'
#' ## Management of NA values.
#' x <- c(NA, TRUE, FALSE)
#' y <- c(NA, NA, NA, NA, FALSE)
#' s_compare(x, .ref_group = y, .in_ref_col = FALSE, na.rm = TRUE)
#' s_compare(x, .ref_group = y, .in_ref_col = FALSE, na.rm = FALSE)
s_compare.logical <- function(x,
                              .ref_group,
                              .in_ref_col,
                              na.rm = TRUE, # nolint
                              denom = "n",
                              ...) {
  denom <- match.arg(denom)

  y <- s_summary.logical(
    x = x,
    na.rm = na.rm,
    denom = denom,
    ...
  )

  if (na.rm) {
    x <- stats::na.omit(x)
    .ref_group <- stats::na.omit(.ref_group)
  } else {
    x[is.na(x)] <- FALSE
    .ref_group[is.na(.ref_group)] <- FALSE
  }

  y$pval <- if (!.in_ref_col && length(x) > 0 && length(.ref_group) > 0) {
    x <- factor(x, levels = c(TRUE, FALSE))
    .ref_group <- factor(.ref_group, levels = c(TRUE, FALSE))
    tbl <- rbind(table(x), table(.ref_group))
    suppressWarnings(prop_chisq(tbl))
  } else {
    character()
  }

  y
}

#' @describeIn compare_variables S3 generic Formatted Analysis function to produce
#'   an object description and comparison versus the reference column in the form
#'   of p-values. It is used as `afun` in [rtables::analyze()].
#'
#' @export
#'
a_compare <- function(x,
                      .ref_group,
                      .in_ref_col,
                      ...,
                      .var) {
  UseMethod("a_compare", x)
}

#' @describeIn compare_variables Formatted Analysis function method for `numeric`.
#' @export
#'
#' @examples
#' # `a_compare.numeric`
#' a_compare(
#'   rnorm(10, 5, 1),
#'   .ref_group = rnorm(20, -5, 1),
#'   .in_ref_col = FALSE,
#'   .var = "bla"
#' )
a_compare.numeric <- make_afun(
  s_compare.numeric,
  .formats = c(
    .a_summary_numeric_formats,
    pval = "x.xxxx | (<0.0001)"
  ),
  .labels = c(
    .a_summary_numeric_labels,
    pval = "p-value (t-test)"
  ),
  .null_ref_cells = FALSE
)

.a_compare_counts_formats <- c(
  .a_summary_counts_formats,
  pval = "x.xxxx | (<0.0001)"
)

.a_compare_counts_labels <- c(
  pval = "p-value (chi-squared test)"
)

#' @describeIn compare_variables Formatted Analysis function method for `factor`.
#' @export
#'
#' @examples
#' # `a_compare.factor`
#' # We need to ungroup `count` and `count_fraction` first so that the `rtables` formatting
#' # functions can be applied correctly.
#' afun <- make_afun(
#'   getS3method("a_compare", "factor"),
#'   .ungroup_stats = c("count", "count_fraction")
#' )
#' x <- factor(c("a", "a", "b", "c", "a"))
#' y <- factor(c("a", "a", "b", "c"))
#' afun(x, .ref_group = y, .in_ref_col = FALSE)
a_compare.factor <- make_afun(
  s_compare.factor,
  .formats = .a_compare_counts_formats,
  .labels = .a_compare_counts_labels,
  .null_ref_cells = FALSE
)

#' @describeIn compare_variables Formatted Analysis function method for `character`.
#' @export
#'
#' @examples
#' # `a_compare.character`
#' afun <- make_afun(
#'   getS3method("a_compare", "character"),
#'   .ungroup_stats = c("count", "count_fraction")
#' )
#' x <- c("A", "B", "A", "C")
#' y <- c("B", "A", "C")
#' afun(x, .ref_group = y, .in_ref_col = FALSE, .var = "x", verbose = FALSE)
a_compare.character <- make_afun(
  s_compare.character,
  .formats = .a_compare_counts_formats,
  .labels = .a_compare_counts_labels,
  .null_ref_cells = FALSE
)

#' @describeIn compare_variables Formatted Analysis function method for `logical`.
#' @export
#'
#' @examples
#' # `a_compare.logical`
#' afun <- make_afun(
#'   getS3method("a_compare", "logical")
#' )
#' x <- c(TRUE, FALSE, FALSE, TRUE, TRUE)
#' y <- c(TRUE, FALSE)
#' afun(x, .ref_group = y, .in_ref_col = FALSE)
a_compare.logical <- make_afun(
  s_compare.logical,
  .formats = .a_compare_counts_formats,
  .labels = .a_compare_counts_labels,
  .null_ref_cells = FALSE
)

#' Constructor Function for [compare_vars()]
#'
#' @description `r lifecycle::badge("stable")` Constructor function which creates a combined Formatted
#' Analysis function for use in layout creating functions [compare_vars()].
#'
#' @note Since [a_compare()] is generic and we want customization of the formatting arguments
#'   via [rtables::make_afun()], we need to create another temporary generic function, with
#'   corresponding customized methods. Then in order for the methods to be found,
#'   we need to wrap them in a combined `afun`. Since this is required by two layout creating
#'   functions (and possibly others in the future), we provide a constructor that does this:
#'   [create_afun_compare()].
#' @export
#' @inheritParams argument_convention
#' @seealso [compare_variables]
#'
#' @examples
#' # `create_afun_compare()` to create combined `afun`
#'
#' afun <- create_afun_compare(
#'   .stats = c("n", "count_fraction", "mean_sd", "pval"),
#'   .indent_mods = c(pval = 1L)
#' )
#'
#' lyt <- basic_table() %>%
#'   split_cols_by("ARMCD", ref_group = "ARM A") %>%
#'   analyze(
#'     "AGE",
#'     afun = afun,
#'     show_labels = "visible"
#'   )
#' build_table(lyt, df = tern_ex_adsl)
#'
#' lyt <- basic_table() %>%
#'   split_cols_by("ARMCD", ref_group = "ARM A") %>%
#'   analyze(
#'     "SEX",
#'     afun = afun,
#'     show_labels = "visible"
#'   )
#' build_table(lyt, df = tern_ex_adsl)
create_afun_compare <- function(.stats = NULL,
                                .formats = NULL,
                                .labels = NULL,
                                .indent_mods = NULL) {
  function(x,
           .ref_group,
           .in_ref_col,
           ...,
           .var) {
    afun <- function(x, ...) {
      UseMethod("afun", x)
    }

    numeric_stats <- afun_selected_stats(
      .stats,
      all_stats = c(names(.a_summary_numeric_formats), "pval")
    )
    afun.numeric <- make_afun( # nolint
      a_compare.numeric,
      .stats = numeric_stats,
      .formats = extract_by_name(.formats, numeric_stats),
      .labels = extract_by_name(.labels, numeric_stats),
      .indent_mods = extract_by_name(.indent_mods, numeric_stats),
      .null_ref_cells = FALSE
    )

    factor_stats <- afun_selected_stats(
      .stats,
      all_stats = names(.a_compare_counts_formats)
    )
    ungroup_stats <- afun_selected_stats(.stats, c("count", "count_fraction"))
    afun.factor <- make_afun( # nolint
      a_compare.factor,
      .stats = factor_stats,
      .formats = extract_by_name(.formats, factor_stats),
      .labels = extract_by_name(.labels, factor_stats),
      .indent_mods = extract_by_name(.indent_mods, factor_stats),
      .ungroup_stats = ungroup_stats,
      .null_ref_cells = FALSE
    )

    afun.character <- make_afun( # nolint
      a_compare.character,
      .stats = factor_stats,
      .formats = extract_by_name(.formats, factor_stats),
      .labels = extract_by_name(.labels, factor_stats),
      .indent_mods = extract_by_name(.indent_mods, factor_stats),
      .ungroup_stats = ungroup_stats,
      .null_ref_cells = FALSE
    )

    afun.logical <- make_afun( # nolint
      a_compare.logical,
      .stats = factor_stats,
      .formats = extract_by_name(.formats, factor_stats),
      .labels = extract_by_name(.labels, factor_stats),
      .indent_mods = extract_by_name(.indent_mods, factor_stats),
      .null_ref_cells = FALSE
    )

    afun(
      x = x,
      .ref_group = .ref_group,
      .in_ref_col = .in_ref_col,
      ...,
      .var = .var
    )
  }
}

#' @describeIn compare_variables Analyze Function to add a comparison of variables to
#'  `rtables` pipelines. The column split needs to have the reference group defined
#'   via `ref_group` so that the comparison is well defined.
#'   The ellipsis (`...`) conveys arguments to [s_compare()].
#'   When factor variables contains `NA`, it is expected that `NA`
#'   have been conveyed to `na_level` appropriately beforehand with
#'   [df_explicit_na()].
#' @inheritParams rtables::analyze
#' @param ... arguments passed to `s_compare()`.
#'
#' @template formatting_arguments
#' @export
#'
#' @examples
#' # `compare_vars()` in `rtables` pipelines
#'
#' ## Default output within a `rtables` pipeline.
#' lyt <- basic_table() %>%
#'   split_cols_by("ARMCD", ref_group = "ARM B") %>%
#'   compare_vars(c("AGE", "SEX"))
#' build_table(lyt, tern_ex_adsl)
#'
#' ## Select and format statistics output.
#' lyt <- basic_table() %>%
#'   split_cols_by("ARMCD", ref_group = "ARM C") %>%
#'   compare_vars(
#'     vars = "AGE",
#'     .stats = c("mean_sd", "pval"),
#'     .formats = c(mean_sd = "xx.x, xx.x"),
#'     .labels = c(mean_sd = "Mean, SD")
#'   )
#' build_table(lyt, df = tern_ex_adsl)
compare_vars <- function(lyt,
                         vars,
                         var_labels = vars,
                         nested = TRUE,
                         ...,
                         show_labels = "default",
                         table_names = vars,
                         .stats = c("n", "mean_sd", "count_fraction", "pval"),
                         .formats = NULL,
                         .labels = NULL,
                         .indent_mods = NULL) {
  afun <- create_afun_compare(.stats, .formats, .labels, .indent_mods)

  analyze(
    lyt = lyt,
    vars = vars,
    var_labels = var_labels,
    afun = afun,
    nested = nested,
    extra_args = list(...),
    inclNAs = TRUE,
    show_labels = show_labels,
    table_names = table_names
  )
}

#' Helper Functions for Multi-Variable Logistic Regression
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Helper functions used in calculations for logistic regression.
#'
#' @inheritParams argument_convention
#' @param fit_glm (`glm`)\cr logistic regression model fitted by [stats::glm()] with "binomial" family.
#'   Limited functionality is also available for conditional logistic regression models fitted by
#'   [survival::clogit()], currently this is used only by [extract_rsp_biomarkers()].
#' @param x (`string` or `character`)\cr a variable or interaction term in `fit_glm` (depending on the
#'   helper function).
#'
#' @name h_logistic_regression
#'
#' @examples
#' library(dplyr)
#' library(broom)
#'
#' adrs_f <- tern_ex_adrs %>%
#'   filter(PARAMCD == "BESRSPI") %>%
#'   filter(RACE %in% c("ASIAN", "WHITE", "BLACK OR AFRICAN AMERICAN")) %>%
#'   mutate(
#'     Response = case_when(AVALC %in% c("PR", "CR") ~ 1, TRUE ~ 0),
#'     RACE = factor(RACE),
#'     SEX = factor(SEX)
#'   )
#' formatters::var_labels(adrs_f) <- c(formatters::var_labels(tern_ex_adrs), Response = "Response")
#' mod1 <- fit_logistic(
#'   data = adrs_f,
#'   variables = list(
#'     response = "Response",
#'     arm = "ARMCD",
#'     covariates = c("AGE", "RACE")
#'   )
#' )
#' mod2 <- fit_logistic(
#'   data = adrs_f,
#'   variables = list(
#'     response = "Response",
#'     arm = "ARMCD",
#'     covariates = c("AGE", "RACE"),
#'     interaction = "AGE"
#'   )
#' )
NULL

#' @describeIn h_logistic_regression Helper function to extract interaction variable names from a fitted
#'   model assuming only one interaction term.
#'
#' @export
h_get_interaction_vars <- function(fit_glm) {
  checkmate::assert_class(fit_glm, "glm")
  terms_name <- attr(stats::terms(fit_glm), "term.labels")
  terms_order <- attr(stats::terms(fit_glm), "order")
  interaction_term <- terms_name[terms_order == 2]
  checkmate::assert_string(interaction_term)
  strsplit(interaction_term, split = ":")[[1]]
}

#' @describeIn h_logistic_regression Helper function to get the right coefficient name from the
#'   interaction variable names and the given levels. The main value here is that the order
#'   of first and second variable is checked in the `interaction_vars` input.
#'
#' @param interaction_vars (`character` of length 2)\cr interaction variable names.
#' @param first_var_with_level (`character` of length 2)\cr the first variable name with
#'   the interaction level.
#' @param second_var_with_level (`character` of length 2)\cr the second variable name with
#'   the interaction level.
#'
#' @export
h_interaction_coef_name <- function(interaction_vars,
                                    first_var_with_level,
                                    second_var_with_level) {
  checkmate::assert_character(interaction_vars, len = 2, any.missing = FALSE)
  checkmate::assert_character(first_var_with_level, len = 2, any.missing = FALSE)
  checkmate::assert_character(second_var_with_level, len = 2, any.missing = FALSE)
  checkmate::assert_subset(c(first_var_with_level[1], second_var_with_level[1]), interaction_vars)

  first_name <- paste(first_var_with_level, collapse = "")
  second_name <- paste(second_var_with_level, collapse = "")
  if (first_var_with_level[1] == interaction_vars[1]) {
    paste(first_name, second_name, sep = ":")
  } else if (second_var_with_level[1] == interaction_vars[1]) {
    paste(second_name, first_name, sep = ":")
  }
}

#' @describeIn h_logistic_regression Helper function to calculate the odds ratio estimates
#'   for the case when both the odds ratio and the interaction variable are categorical.
#'
#' @param odds_ratio_var (`string`)\cr the odds ratio variable.
#' @param interaction_var (`string`)\cr the interaction variable.
#'
#' @export
h_or_cat_interaction <- function(odds_ratio_var,
                                 interaction_var,
                                 fit_glm,
                                 conf_level = 0.95) {
  interaction_vars <- h_get_interaction_vars(fit_glm)
  checkmate::assert_string(odds_ratio_var)
  checkmate::assert_string(interaction_var)
  checkmate::assert_subset(c(odds_ratio_var, interaction_var), interaction_vars)
  checkmate::assert_vector(interaction_vars, len = 2)

  xs_level <- fit_glm$xlevels
  xs_coef <- stats::coef(fit_glm)
  xs_vcov <- stats::vcov(fit_glm)
  y <- list()
  for (var_level in xs_level[[odds_ratio_var]][-1]) {
    x <- list()
    for (ref_level in xs_level[[interaction_var]]) {
      coef_names <- paste0(odds_ratio_var, var_level)
      if (ref_level != xs_level[[interaction_var]][1]) {
        interaction_coef_name <- h_interaction_coef_name(
          interaction_vars,
          c(odds_ratio_var, var_level),
          c(interaction_var, ref_level)
        )
        coef_names <- c(
          coef_names,
          interaction_coef_name
        )
      }
      if (length(coef_names) > 1) {
        ones <- t(c(1, 1))
        est <- as.numeric(ones %*% xs_coef[coef_names])
        se <- sqrt(as.numeric(ones %*% xs_vcov[coef_names, coef_names] %*% t(ones)))
      } else {
        est <- xs_coef[coef_names]
        se <- sqrt(as.numeric(xs_vcov[coef_names, coef_names]))
      }
      or <- exp(est)
      ci <- exp(est + c(lcl = -1, ucl = 1) * stats::qnorm((1 + conf_level) / 2) * se)
      x[[ref_level]] <- list(or = or, ci = ci)
    }
    y[[var_level]] <- x
  }
  y
}

#' @describeIn h_logistic_regression Helper function to calculate the odds ratio estimates
#'   for the case when either the odds ratio or the interaction variable is continuous.
#'
#' @param at (`NULL` or `numeric`)\cr optional values for the interaction variable. Otherwise
#'   the median is used.
#' @note We don't provide a function for the case when both variables are continuous because
#'   this does not arise in this table, as the treatment arm variable will always be involved
#'   and categorical.
#'
#' @export
h_or_cont_interaction <- function(odds_ratio_var,
                                  interaction_var,
                                  fit_glm,
                                  at = NULL,
                                  conf_level = 0.95) {
  interaction_vars <- h_get_interaction_vars(fit_glm)
  checkmate::assert_string(odds_ratio_var)
  checkmate::assert_string(interaction_var)
  checkmate::assert_subset(c(odds_ratio_var, interaction_var), interaction_vars)
  checkmate::assert_vector(interaction_vars, len = 2)
  checkmate::assert_numeric(at, min.len = 1, null.ok = TRUE, any.missing = FALSE)
  xs_level <- fit_glm$xlevels
  xs_coef <- stats::coef(fit_glm)
  xs_vcov <- stats::vcov(fit_glm)
  xs_class <- attr(fit_glm$terms, "dataClasses")
  model_data <- fit_glm$model
  if (!is.null(at)) {
    checkmate::assert_set_equal(xs_class[interaction_var], "numeric")
  }
  y <- list()
  if (xs_class[interaction_var] == "numeric") {
    if (is.null(at)) {
      at <- ceiling(stats::median(model_data[[interaction_var]]))
    }

    for (var_level in xs_level[[odds_ratio_var]][-1]) {
      x <- list()
      for (increment in at) {
        coef_names <- paste0(odds_ratio_var, var_level)
        if (increment != 0) {
          interaction_coef_name <- h_interaction_coef_name(
            interaction_vars,
            c(odds_ratio_var, var_level),
            c(interaction_var, "")
          )
          coef_names <- c(
            coef_names,
            interaction_coef_name
          )
        }
        if (length(coef_names) > 1) {
          xvec <- t(c(1, increment))
          est <- as.numeric(xvec %*% xs_coef[coef_names])
          se <- sqrt(as.numeric(xvec %*% xs_vcov[coef_names, coef_names] %*% t(xvec)))
        } else {
          est <- xs_coef[coef_names]
          se <- sqrt(as.numeric(xs_vcov[coef_names, coef_names]))
        }
        or <- exp(est)
        ci <- exp(est + c(lcl = -1, ucl = 1) * stats::qnorm((1 + conf_level) / 2) * se)
        x[[as.character(increment)]] <- list(or = or, ci = ci)
      }
      y[[var_level]] <- x
    }
  } else {
    checkmate::assert_set_equal(xs_class[odds_ratio_var], "numeric")
    checkmate::assert_set_equal(xs_class[interaction_var], "factor")
    for (var_level in xs_level[[interaction_var]]) {
      coef_names <- odds_ratio_var
      if (var_level != xs_level[[interaction_var]][1]) {
        interaction_coef_name <- h_interaction_coef_name(
          interaction_vars,
          c(odds_ratio_var, ""),
          c(interaction_var, var_level)
        )
        coef_names <- c(
          coef_names,
          interaction_coef_name
        )
      }
      if (length(coef_names) > 1) {
        xvec <- t(c(1, 1))
        est <- as.numeric(xvec %*% xs_coef[coef_names])
        se <- sqrt(as.numeric(xvec %*% xs_vcov[coef_names, coef_names] %*% t(xvec)))
      } else {
        est <- xs_coef[coef_names]
        se <- sqrt(as.numeric(xs_vcov[coef_names, coef_names]))
      }
      or <- exp(est)
      ci <- exp(est + c(lcl = -1, ucl = 1) * stats::qnorm((1 + conf_level) / 2) * se)
      y[[var_level]] <- list(or = or, ci = ci)
    }
  }
  y
}

#' @describeIn h_logistic_regression Helper function to calculate the odds ratio estimates
#'   in case of an interaction. This is a wrapper for [h_or_cont_interaction()] and
#'   [h_or_cat_interaction()].
#'
#' @export
h_or_interaction <- function(odds_ratio_var,
                             interaction_var,
                             fit_glm,
                             at = NULL,
                             conf_level = 0.95) {
  xs_class <- attr(fit_glm$terms, "dataClasses")
  if (any(xs_class[c(odds_ratio_var, interaction_var)] == "numeric")) {
    h_or_cont_interaction(
      odds_ratio_var,
      interaction_var,
      fit_glm,
      at = at,
      conf_level = conf_level
    )
  } else if (all(xs_class[c(odds_ratio_var, interaction_var)] == "factor")) {
    h_or_cat_interaction(
      odds_ratio_var,
      interaction_var,
      fit_glm,
      conf_level = conf_level
    )
  } else {
    stop("wrong interaction variable class, the interaction variable is not a numeric nor a factor")
  }
}

#' @describeIn h_logistic_regression Helper function to construct term labels from simple terms and the table
#'   of numbers of patients.
#'
#' @param terms (`character`)\cr simple terms.
#' @param table (`table`)\cr table containing numbers for terms.
#'
#' @export
h_simple_term_labels <- function(terms,
                                 table) {
  checkmate::assert_true(is.table(table))
  checkmate::assert_multi_class(terms, classes = c("factor", "character"))
  terms <- as.character(terms)
  term_n <- table[terms]
  paste0(terms, ", n = ", term_n)
}

#' @describeIn h_logistic_regression Helper function to construct term labels from interaction terms and the table
#'   of numbers of patients.
#'
#' @param terms1 (`character`)\cr terms for first dimension (rows).
#' @param terms2 (`character`)\cr terms for second dimension (rows).
#' @param any (`flag`)\cr whether any of `term1` and `term2` can be fulfilled to count the
#'   number of patients. In that case they can only be scalar (strings).
#'
#' @export
h_interaction_term_labels <- function(terms1,
                                      terms2,
                                      table,
                                      any = FALSE) {
  checkmate::assert_true(is.table(table))
  checkmate::assert_flag(any)
  checkmate::assert_multi_class(terms1, classes = c("factor", "character"))
  checkmate::assert_multi_class(terms2, classes = c("factor", "character"))
  terms1 <- as.character(terms1)
  terms2 <- as.character(terms2)
  if (any) {
    checkmate::assert_scalar(terms1)
    checkmate::assert_scalar(terms2)
    paste0(
      terms1, " or ", terms2, ", n = ",
      # Note that we double count in the initial sum the cell [terms1, terms2], therefore subtract.
      sum(c(table[terms1, ], table[, terms2])) - table[terms1, terms2]
    )
  } else {
    term_n <- table[cbind(terms1, terms2)]
    paste0(terms1, " * ", terms2, ", n = ", term_n)
  }
}

#' @describeIn h_logistic_regression Helper function to tabulate the main effect
#'   results of a (conditional) logistic regression model.
#'
#' @examples
#' h_glm_simple_term_extract("AGE", mod1)
#' h_glm_simple_term_extract("ARMCD", mod1)
#'
#' @export
h_glm_simple_term_extract <- function(x, fit_glm) {
  checkmate::assert_multi_class(fit_glm, c("glm", "clogit"))
  checkmate::assert_string(x)

  xs_class <- attr(fit_glm$terms, "dataClasses")
  xs_level <- fit_glm$xlevels
  xs_coef <- summary(fit_glm)$coefficients
  stats <- if (inherits(fit_glm, "glm")) {
    c("estimate" = "Estimate", "std_error" = "Std. Error", "pvalue" = "Pr(>|z|)")
  } else {
    c("estimate" = "coef", "std_error" = "se(coef)", "pvalue" = "Pr(>|z|)")
  }
  # Make sure x is not an interaction term.
  checkmate::assert_subset(x, names(xs_class))
  x_sel <- if (xs_class[x] == "numeric") x else paste0(x, xs_level[[x]][-1])
  x_stats <- as.data.frame(xs_coef[x_sel, stats, drop = FALSE], stringsAsFactors = FALSE)
  colnames(x_stats) <- names(stats)
  x_stats$estimate <- as.list(x_stats$estimate)
  x_stats$std_error <- as.list(x_stats$std_error)
  x_stats$pvalue <- as.list(x_stats$pvalue)
  x_stats$df <- as.list(1)
  if (xs_class[x] == "numeric") {
    x_stats$term <- x
    x_stats$term_label <- if (inherits(fit_glm, "glm")) {
      formatters::var_labels(fit_glm$data[x], fill = TRUE)
    } else {
      # We just fill in here with the `term` itself as we don't have the data available.
      x
    }
    x_stats$is_variable_summary <- FALSE
    x_stats$is_term_summary <- TRUE
  } else {
    checkmate::assert_class(fit_glm, "glm")
    # The reason is that we don't have the original data set in the `clogit` object
    # and therefore cannot determine the `x_numbers` here.
    x_numbers <- table(fit_glm$data[[x]])
    x_stats$term <- xs_level[[x]][-1]
    x_stats$term_label <- h_simple_term_labels(x_stats$term, x_numbers)
    x_stats$is_variable_summary <- FALSE
    x_stats$is_term_summary <- TRUE
    main_effects <- car::Anova(fit_glm, type = 3, test.statistic = "Wald")
    x_main <- data.frame(
      pvalue = main_effects[x, "Pr(>Chisq)", drop = TRUE],
      term = xs_level[[x]][1],
      term_label = paste("Reference", h_simple_term_labels(xs_level[[x]][1], x_numbers)),
      df = main_effects[x, "Df", drop = TRUE],
      stringsAsFactors = FALSE
    )
    x_main$pvalue <- as.list(x_main$pvalue)
    x_main$df <- as.list(x_main$df)
    x_main$estimate <- list(numeric(0))
    x_main$std_error <- list(numeric(0))
    if (length(xs_level[[x]][-1]) == 1) {
      x_main$pvalue <- list(numeric(0))
      x_main$df <- list(numeric(0))
    }
    x_main$is_variable_summary <- TRUE
    x_main$is_term_summary <- FALSE
    x_stats <- rbind(x_main, x_stats)
  }
  x_stats$variable <- x
  x_stats$variable_label <- if (inherits(fit_glm, "glm")) {
    formatters::var_labels(fit_glm$data[x], fill = TRUE)
  } else {
    x
  }
  x_stats$interaction <- ""
  x_stats$interaction_label <- ""
  x_stats$reference <- ""
  x_stats$reference_label <- ""
  rownames(x_stats) <- NULL
  x_stats[c(
    "variable",
    "variable_label",
    "term",
    "term_label",
    "interaction",
    "interaction_label",
    "reference",
    "reference_label",
    "estimate",
    "std_error",
    "df",
    "pvalue",
    "is_variable_summary",
    "is_term_summary"
  )]
}

#' @describeIn h_logistic_regression Helper function to tabulate the interaction term
#'   results of a logistic regression model.
#'
#' @examples
#' h_glm_interaction_extract("ARMCD:AGE", mod2)
#'
#' @export
h_glm_interaction_extract <- function(x, fit_glm) {
  vars <- h_get_interaction_vars(fit_glm)
  xs_class <- attr(fit_glm$terms, "dataClasses")

  checkmate::assert_string(x)

  # Only take two-way interaction
  checkmate::assert_vector(vars, len = 2)

  # Only consider simple case: first variable in interaction is arm, a categorical variable
  checkmate::assert_disjunct(xs_class[vars[1]], "numeric")

  xs_level <- fit_glm$xlevels
  xs_coef <- summary(fit_glm)$coefficients
  main_effects <- car::Anova(fit_glm, type = 3, test.statistic = "Wald")
  stats <- c("estimate" = "Estimate", "std_error" = "Std. Error", "pvalue" = "Pr(>|z|)")
  v1_comp <- xs_level[[vars[1]]][-1]
  if (xs_class[vars[2]] == "numeric") {
    x_stats <- as.data.frame(
      xs_coef[paste0(vars[1], v1_comp, ":", vars[2]), stats, drop = FALSE],
      stringsAsFactors = FALSE
    )
    colnames(x_stats) <- names(stats)
    x_stats$term <- v1_comp
    x_numbers <- table(fit_glm$data[[vars[1]]])
    x_stats$term_label <- h_simple_term_labels(v1_comp, x_numbers)
    v1_ref <- xs_level[[vars[1]]][1]
    term_main <- v1_ref
    ref_label <- h_simple_term_labels(v1_ref, x_numbers)
  } else if (xs_class[vars[2]] != "numeric") {
    v2_comp <- xs_level[[vars[2]]][-1]
    v1_v2_grid <- expand.grid(v1 = v1_comp, v2 = v2_comp)
    x_sel <- paste(
      paste0(vars[1], v1_v2_grid$v1),
      paste0(vars[2], v1_v2_grid$v2),
      sep = ":"
    )
    x_stats <- as.data.frame(xs_coef[x_sel, stats, drop = FALSE], stringsAsFactors = FALSE)
    colnames(x_stats) <- names(stats)
    x_stats$term <- paste(v1_v2_grid$v1, "*", v1_v2_grid$v2)
    x_numbers <- table(fit_glm$data[[vars[1]]], fit_glm$data[[vars[2]]])
    x_stats$term_label <- h_interaction_term_labels(v1_v2_grid$v1, v1_v2_grid$v2, x_numbers)
    v1_ref <- xs_level[[vars[1]]][1]
    v2_ref <- xs_level[[vars[2]]][1]
    term_main <- paste(vars[1], vars[2], sep = " * ")
    ref_label <- h_interaction_term_labels(v1_ref, v2_ref, x_numbers, any = TRUE)
  }
  x_stats$df <- as.list(1)
  x_stats$pvalue <- as.list(x_stats$pvalue)
  x_stats$is_variable_summary <- FALSE
  x_stats$is_term_summary <- TRUE
  x_main <- data.frame(
    pvalue = main_effects[x, "Pr(>Chisq)", drop = TRUE],
    term = term_main,
    term_label = paste("Reference", ref_label),
    df = main_effects[x, "Df", drop = TRUE],
    stringsAsFactors = FALSE
  )
  x_main$pvalue <- as.list(x_main$pvalue)
  x_main$df <- as.list(x_main$df)
  x_main$estimate <- list(numeric(0))
  x_main$std_error <- list(numeric(0))
  x_main$is_variable_summary <- TRUE
  x_main$is_term_summary <- FALSE

  x_stats <- rbind(x_main, x_stats)
  x_stats$variable <- x
  x_stats$variable_label <- paste(
    "Interaction of",
    formatters::var_labels(fit_glm$data[vars[1]], fill = TRUE),
    "*",
    formatters::var_labels(fit_glm$data[vars[2]], fill = TRUE)
  )
  x_stats$interaction <- ""
  x_stats$interaction_label <- ""
  x_stats$reference <- ""
  x_stats$reference_label <- ""
  rownames(x_stats) <- NULL
  x_stats[c(
    "variable",
    "variable_label",
    "term",
    "term_label",
    "interaction",
    "interaction_label",
    "reference",
    "reference_label",
    "estimate",
    "std_error",
    "df",
    "pvalue",
    "is_variable_summary",
    "is_term_summary"
  )]
}

#' @describeIn h_logistic_regression Helper function to tabulate the interaction
#'   results of a logistic regression model. This basically is a wrapper for
#'   [h_or_interaction()] and [h_glm_simple_term_extract()] which puts the results
#'   in the right data frame format.
#'
#' @examples
#' h_glm_inter_term_extract("AGE", "ARMCD", mod2)
#'
#' @export
h_glm_inter_term_extract <- function(odds_ratio_var,
                                     interaction_var,
                                     fit_glm,
                                     ...) {
  # First obtain the main effects.
  main_stats <- h_glm_simple_term_extract(odds_ratio_var, fit_glm)
  main_stats$is_reference_summary <- FALSE
  main_stats$odds_ratio <- NA
  main_stats$lcl <- NA
  main_stats$ucl <- NA

  # Then we get the odds ratio estimates and put into df form.
  or_numbers <- h_or_interaction(odds_ratio_var, interaction_var, fit_glm, ...)
  is_num_or_var <- attr(fit_glm$terms, "dataClasses")[odds_ratio_var] == "numeric"

  if (is_num_or_var) {
    # Numeric OR variable case.
    references <- names(or_numbers)
    n_ref <- length(references)

    extract_from_list <- function(l, name, pos = 1) {
      unname(unlist(
        lapply(or_numbers, function(x) {
          x[[name]][pos]
        })
      ))
    }
    or_stats <- data.frame(
      variable = odds_ratio_var,
      variable_label = unname(formatters::var_labels(fit_glm$data[odds_ratio_var], fill = TRUE)),
      term = odds_ratio_var,
      term_label = unname(formatters::var_labels(fit_glm$data[odds_ratio_var], fill = TRUE)),
      interaction = interaction_var,
      interaction_label = unname(formatters::var_labels(fit_glm$data[interaction_var], fill = TRUE)),
      reference = references,
      reference_label = references,
      estimate = NA,
      std_error = NA,
      odds_ratio = extract_from_list(or_numbers, "or"),
      lcl = extract_from_list(or_numbers, "ci", pos = "lcl"),
      ucl = extract_from_list(or_numbers, "ci", pos = "ucl"),
      df = NA,
      pvalue = NA,
      is_variable_summary = FALSE,
      is_term_summary = FALSE,
      is_reference_summary = TRUE
    )
  } else {
    # Categorical OR variable case.
    references <- names(or_numbers[[1]])
    n_ref <- length(references)

    extract_from_list <- function(l, name, pos = 1) {
      unname(unlist(
        lapply(or_numbers, function(x) {
          lapply(x, function(y) y[[name]][pos])
        })
      ))
    }
    or_stats <- data.frame(
      variable = odds_ratio_var,
      variable_label = unname(formatters::var_labels(fit_glm$data[odds_ratio_var], fill = TRUE)),
      term = rep(names(or_numbers), each = n_ref),
      term_label = h_simple_term_labels(rep(names(or_numbers), each = n_ref), table(fit_glm$data[[odds_ratio_var]])),
      interaction = interaction_var,
      interaction_label = unname(formatters::var_labels(fit_glm$data[interaction_var], fill = TRUE)),
      reference = unlist(lapply(or_numbers, names)),
      reference_label = unlist(lapply(or_numbers, names)),
      estimate = NA,
      std_error = NA,
      odds_ratio = extract_from_list(or_numbers, "or"),
      lcl = extract_from_list(or_numbers, "ci", pos = "lcl"),
      ucl = extract_from_list(or_numbers, "ci", pos = "ucl"),
      df = NA,
      pvalue = NA,
      is_variable_summary = FALSE,
      is_term_summary = FALSE,
      is_reference_summary = TRUE
    )
  }

  df <- rbind(
    main_stats[, names(or_stats)],
    or_stats
  )
  df[order(-df$is_variable_summary, df$term, -df$is_term_summary, df$reference), ]
}

#' @describeIn h_logistic_regression Helper function to tabulate the results including
#'   odds ratios and confidence intervals of simple terms.
#' @export
#'
#' @examples
#' h_logistic_simple_terms("AGE", mod1)
h_logistic_simple_terms <- function(x, fit_glm, conf_level = 0.95) {
  checkmate::assert_multi_class(fit_glm, c("glm", "clogit"))
  if (inherits(fit_glm, "glm")) {
    checkmate::assert_set_equal(fit_glm$family$family, "binomial")
  }
  terms_name <- attr(stats::terms(fit_glm), "term.labels")
  xs_class <- attr(fit_glm$terms, "dataClasses")
  interaction <- terms_name[which(!terms_name %in% names(xs_class))]
  checkmate::assert_subset(x, terms_name)
  if (length(interaction) != 0) {
    # Make sure any item in x is not part of interaction term
    checkmate::assert_disjunct(x, unlist(strsplit(interaction, ":")))
  }
  x_stats <- lapply(x, h_glm_simple_term_extract, fit_glm)
  x_stats <- do.call(rbind, x_stats)
  q_norm <- stats::qnorm((1 + conf_level) / 2)
  x_stats$odds_ratio <- lapply(x_stats$estimate, exp)
  x_stats$lcl <- Map(function(or, se) exp(log(or) - q_norm * se), x_stats$odds_ratio, x_stats$std_error)
  x_stats$ucl <- Map(function(or, se) exp(log(or) + q_norm * se), x_stats$odds_ratio, x_stats$std_error)
  x_stats$ci <- Map(function(lcl, ucl) c(lcl, ucl), lcl = x_stats$lcl, ucl = x_stats$ucl)
  x_stats
}

#' @describeIn h_logistic_regression Helper function to tabulate the results including
#'   odds ratios and confidence intervals of interaction terms.
#'
#' @examples
#' h_logistic_inter_terms(c("RACE", "AGE", "ARMCD", "AGE:ARMCD"), mod2)
#'
#' @export
h_logistic_inter_terms <- function(x,
                                   fit_glm,
                                   conf_level = 0.95,
                                   at = NULL) {
  # Find out the interaction variables and interaction term.
  inter_vars <- h_get_interaction_vars(fit_glm)
  checkmate::assert_vector(inter_vars, len = 2)


  inter_term_index <- intersect(grep(inter_vars[1], x), grep(inter_vars[2], x))
  inter_term <- x[inter_term_index]

  # For the non-interaction vars we need the standard stuff.
  normal_terms <- setdiff(x, union(inter_vars, inter_term))

  x_stats <- lapply(normal_terms, h_glm_simple_term_extract, fit_glm)
  x_stats <- do.call(rbind, x_stats)
  q_norm <- stats::qnorm((1 + conf_level) / 2)
  x_stats$odds_ratio <- lapply(x_stats$estimate, exp)
  x_stats$lcl <- Map(function(or, se) exp(log(or) - q_norm * se), x_stats$odds_ratio, x_stats$std_error)
  x_stats$ucl <- Map(function(or, se) exp(log(or) + q_norm * se), x_stats$odds_ratio, x_stats$std_error)
  normal_stats <- x_stats
  normal_stats$is_reference_summary <- FALSE

  # Now the interaction term itself.
  inter_term_stats <- h_glm_interaction_extract(inter_term, fit_glm)
  inter_term_stats$odds_ratio <- NA
  inter_term_stats$lcl <- NA
  inter_term_stats$ucl <- NA
  inter_term_stats$is_reference_summary <- FALSE

  is_intervar1_numeric <- attr(fit_glm$terms, "dataClasses")[inter_vars[1]] == "numeric"

  # Interaction stuff.
  inter_stats_one <- h_glm_inter_term_extract(
    inter_vars[1],
    inter_vars[2],
    fit_glm,
    conf_level = conf_level,
    at = `if`(is_intervar1_numeric, NULL, at)
  )
  inter_stats_two <- h_glm_inter_term_extract(
    inter_vars[2],
    inter_vars[1],
    fit_glm,
    conf_level = conf_level,
    at = `if`(is_intervar1_numeric, at, NULL)
  )

  # Now just combine everything in one data frame.
  col_names <- c(
    "variable",
    "variable_label",
    "term",
    "term_label",
    "interaction",
    "interaction_label",
    "reference",
    "reference_label",
    "estimate",
    "std_error",
    "df",
    "pvalue",
    "odds_ratio",
    "lcl",
    "ucl",
    "is_variable_summary",
    "is_term_summary",
    "is_reference_summary"
  )
  df <- rbind(
    inter_stats_one[, col_names],
    inter_stats_two[, col_names],
    inter_term_stats[, col_names]
  )
  if (length(normal_terms) > 0) {
    df <- rbind(
      normal_stats[, col_names],
      df
    )
  }
  df$ci <- combine_vectors(df$lcl, df$ucl)
  df
}

#' Line plot with the optional table
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Line plot with the optional table.
#'
#' @param df (`data.frame`)\cr data set containing all analysis variables.
#' @param alt_counts_df (`data.frame` or `NULL`)\cr data set that will be used (only) to counts objects in strata.
#' @param variables (named `character` vector) of variable names in `df` data set. Details are:
#'   * `x` (`character`)\cr name of x-axis variable.
#'   * `y` (`character`)\cr name of y-axis variable.
#'   * `strata` (`character`)\cr name of grouping variable, i.e. treatment arm. Can be `NA` to indicate lack of groups.
#'   * `paramcd` (`character`)\cr name of the variable for parameter's code. Used for y-axis label and plot's subtitle.
#'     Can be `NA` if paramcd is not to be added to the y-axis label or subtitle.
#'   * `y_unit` (`character`)\cr name of variable with units of `y`. Used for y-axis label and plot's subtitle.
#'     Can be `NA` if y unit is not to be added to the y-axis label or subtitle.
#' @param mid (`character` or `NULL`)\cr names of the statistics that will be plotted as midpoints.
#'   All the statistics indicated in `mid` variable must be present in the object returned by `sfun`,
#'   and be of a `double` or `numeric` type vector of length one.
#' @param interval (`character` or `NULL`)\cr names of the statistics that will be plotted as intervals.
#'   All the statistics indicated in `interval` variable must be present in the object returned by `sfun`,
#'   and be of a `double` or `numeric` type vector of length two.
#' @param whiskers (`character`)\cr names of the interval whiskers that will be plotted. Must match the `names`
#'   attribute of the `interval` element in the list returned by `sfun`. It is possible to specify one whisker only,
#'   lower or upper.
#' @param table (`character` or `NULL`)\cr names of the statistics that will be displayed in the table below the plot.
#'   All the statistics indicated in `table` variable must be present in the object returned by `sfun`.
#' @param sfun (`closure`)\cr the function to compute the values of required statistics. It must return a named `list`
#'   with atomic vectors. The names of the `list` elements refer to the names of the statistics and are used by `mid`,
#'   `interval`, `table`. It must be able to accept as input a vector with data for which statistics are computed.
#' @param ... optional arguments to `sfun`.
#' @param mid_type (`character`)\cr controls the type of the `mid` plot, it can be point (`p`), line (`l`),
#'   or point and line (`pl`).
#' @param mid_point_size (`integer` or `double`)\cr controls the font size of the point for `mid` plot.
#' @param position (`character` or `call`)\cr geom element position adjustment, either as a string, or the result of
#'   a call to a position adjustment function.
#' @param legend_title (`character` string)\cr legend title.
#' @param legend_position (`character`)\cr the position of the plot legend (`none`, `left`, `right`, `bottom`, `top`,
#'   or two-element numeric vector).
#' @param ggtheme (`theme`)\cr a graphical theme as provided by `ggplot2` to control styling of the plot.
#' @param y_lab (`character`)\cr y-axis label. If equal to `NULL`, then no label will be added.
#' @param y_lab_add_paramcd (`logical`)\cr should paramcd, i.e. `unique(df[[variables["paramcd"]]])` be added to the
#'   y-axis label `y_lab`?
#' @param y_lab_add_unit (`logical`)\cr should y unit, i.e. `unique(df[[variables["y_unit"]]])` be added to the y-axis
#'   label `y_lab`?
#' @param title (`character`)\cr plot title.
#' @param subtitle (`character`)\cr plot subtitle.
#' @param subtitle_add_paramcd (`logical`)\cr should paramcd, i.e. `unique(df[[variables["paramcd"]]])` be added to
#'   the plot's subtitle `subtitle`?
#' @param subtitle_add_unit (`logical`)\cr should y unit, i.e. `unique(df[[variables["y_unit"]]])` be added to the
#'   plot's subtitle `subtitle`?
#' @param caption (`character`)\cr optional caption below the plot.
#' @param table_format (named `character` or `NULL`)\cr format patterns for descriptive statistics used in the
#'   (optional) table appended to the plot. It is passed directly to the `h_format_row` function through the `format`
#'   parameter. Names of `table_format` must match the names of statistics returned by `sfun` function.
#' @param table_labels (named `character` or `NULL`)\cr labels for descriptive statistics used in the (optional) table
#'   appended to the plot. Names of `table_labels` must match the names of statistics returned by `sfun` function.
#' @param table_font_size (`integer` or `double`)\cr controls the font size of values in the table.
#' @param newpage (`logical`)\cr should plot be drawn on new page?
#' @param col (`character`)\cr colors.
#'
#' @author Wojciech Wojciak wojciech.wojciak@contractors.roche.com
#'
#' @return \code{ggplot}
#'
#' @export
#'
#' @examples
#' library(nestcolor)
#'
#' adsl <- tern_ex_adsl
#' adlb <- tern_ex_adlb %>% dplyr::filter(ANL01FL == "Y", PARAMCD == "ALT", AVISIT != "SCREENING")
#' adlb$AVISIT <- droplevels(adlb$AVISIT)
#' adlb <- dplyr::mutate(adlb, AVISIT = forcats::fct_reorder(AVISIT, AVISITN, min))
#'
#' # Mean with CI
#' g_lineplot(adlb, adsl, subtitle = "Laboratory Test:")
#'
#' # Mean with CI, no stratification
#' g_lineplot(adlb, variables = control_lineplot_vars(strata = NA))
#'
#' # Mean, upper whisker of CI, no strata counts N
#' g_lineplot(
#'   adlb,
#'   whiskers = "mean_ci_upr",
#'   title = "Plot of Mean and Upper 95% Confidence Limit by Visit"
#' )
#'
#' # Median with CI
#' g_lineplot(
#'   adlb,
#'   adsl,
#'   mid = "median",
#'   interval = "median_ci",
#'   whiskers = c("median_ci_lwr", "median_ci_upr"),
#'   title = "Plot of Median and 95% Confidence Limits by Visit"
#' )
#'
#' # Mean, +/- SD
#' g_lineplot(adlb, adsl,
#'   interval = "mean_sdi",
#'   whiskers = c("mean_sdi_lwr", "mean_sdi_upr"),
#'   title = "Plot of Median +/- SD by Visit"
#' )
#'
#' # Mean with CI plot with stats table
#' g_lineplot(adlb, adsl, table = c("n", "mean", "mean_ci"))
#'
#' # Mean with CI, table and customized confidence level
#' g_lineplot(
#'   adlb,
#'   adsl,
#'   table = c("n", "mean", "mean_ci"),
#'   control = control_summarize_vars(conf_level = 0.80),
#'   title = "Plot of Mean and 80% Confidence Limits by Visit"
#' )
#'
#' # Mean with CI, table, filtered data
#' adlb_f <- dplyr::filter(adlb, ARMCD != "ARM A" | AVISIT == "BASELINE")
#' g_lineplot(adlb_f, table = c("n", "mean"))
g_lineplot <- function(df, # nolint
                       alt_counts_df = NULL,
                       variables = control_lineplot_vars(),
                       mid = "mean",
                       interval = "mean_ci",
                       whiskers = c("mean_ci_lwr", "mean_ci_upr"),
                       table = NULL,
                       sfun = tern::s_summary,
                       ...,
                       mid_type = "pl",
                       mid_point_size = 2,
                       position = ggplot2::position_dodge(width = 0.4),
                       legend_title = NULL,
                       legend_position = "bottom",
                       ggtheme = nestcolor::theme_nest(),
                       y_lab = NULL,
                       y_lab_add_paramcd = TRUE,
                       y_lab_add_unit = TRUE,
                       title = "Plot of Mean and 95% Confidence Limits by Visit",
                       subtitle = "",
                       subtitle_add_paramcd = TRUE,
                       subtitle_add_unit = TRUE,
                       caption = NULL,
                       table_format = summary_formats(),
                       table_labels = summary_labels(),
                       table_font_size = 3,
                       newpage = TRUE,
                       col = NULL) {
  checkmate::assert_character(variables, any.missing = TRUE)
  checkmate::assert_character(mid, null.ok = TRUE)
  checkmate::assert_character(interval, null.ok = TRUE)
  checkmate::assert_character(col, null.ok = TRUE)

  checkmate::assert_string(title, null.ok = TRUE)
  checkmate::assert_string(subtitle, null.ok = TRUE)

  if (is.character(interval)) {
    checkmate::assert_vector(whiskers, min.len = 0, max.len = 2)
  }

  if (length(whiskers) == 1) {
    checkmate::assert_character(mid)
  }

  if (is.character(mid)) {
    checkmate::assert_scalar(mid_type)
    checkmate::assert_subset(mid_type, c("pl", "p", "l"))
  }

  x <- variables[["x"]]
  y <- variables[["y"]]
  paramcd <- variables["paramcd"] # NA if paramcd == NA or it is not in variables
  y_unit <- variables["y_unit"] # NA if y_unit == NA or it is not in variables
  if (is.na(variables["strata"])) {
    strata <- NULL # NULL if strata == NA or it is not in variables
  } else {
    strata <- variables[["strata"]]
  }
  checkmate::assert_flag(y_lab_add_paramcd, null.ok = TRUE)
  checkmate::assert_flag(subtitle_add_paramcd, null.ok = TRUE)
  if ((!is.null(y_lab) && y_lab_add_paramcd) || (!is.null(subtitle) && subtitle_add_paramcd)) {
    checkmate::assert_false(is.na(paramcd))
    checkmate::assert_scalar(unique(df[[paramcd]]))
  }

  checkmate::assert_flag(y_lab_add_unit, null.ok = TRUE)
  checkmate::assert_flag(subtitle_add_unit, null.ok = TRUE)
  if ((!is.null(y_lab) && y_lab_add_unit) || (!is.null(subtitle) && subtitle_add_unit)) {
    checkmate::assert_false(is.na(y_unit))
    checkmate::assert_scalar(unique(df[[y_unit]]))
  }

  if (!is.null(strata) && !is.null(alt_counts_df)) {
    checkmate::assert_set_equal(unique(alt_counts_df[[strata]]), unique(df[[strata]]))
  }

  ####################################### |
  # ---- Compute required statistics ----
  ####################################### |
  if (!is.null(strata)) {
    df_grp <- tidyr::expand(df, .data[[strata]], .data[[x]]) # expand based on levels of factors
  } else {
    df_grp <- tidyr::expand(df, NULL, .data[[x]])
  }
  df_grp <- df_grp %>%
    dplyr::full_join(y = df[, c(strata, x, y)], by = c(strata, x), multiple = "all") %>%
    dplyr::group_by_at(c(strata, x))

  df_stats <- df_grp %>%
    dplyr::summarise(
      data.frame(t(do.call(c, unname(sfun(.data[[y]], ...)[c(mid, interval)])))),
      .groups = "drop"
    )

  df_stats <- df_stats %>% dplyr::filter(!is.na(mid))

  # add number of objects N in strata
  if (!is.null(strata) && !is.null(alt_counts_df)) {
    strata_N <- paste0(strata, "_N") # nolint

    df_N <- as.data.frame(table(alt_counts_df[[strata]], exclude = c(NA, NaN, Inf))) # nolint
    colnames(df_N) <- c(strata, "N") # nolint
    df_N[[strata_N]] <- paste0(df_N[[strata]], " (N = ", df_N$N, ")") # nolint

    # strata_N should not be in clonames(df_stats)
    checkmate::assert_disjunct(strata_N, colnames(df_stats))

    df_stats <- merge(x = df_stats, y = df_N[, c(strata, strata_N)], by = strata)
  } else if (!is.null(strata)) {
    strata_N <- strata # nolint
  } else {
    strata_N <- NULL # nolint
  }

  ############################################### |
  # ---- Prepare certain plot's properties. ----
  ############################################### |
  # legend title
  if (is.null(legend_title) && !is.null(strata) && legend_position != "none") {
    legend_title <- attr(df[[strata]], "label")
  }

  # y label
  if (!is.null(y_lab)) {
    if (y_lab_add_paramcd) {
      y_lab <- paste(y_lab, unique(df[[paramcd]]))
    }

    if (y_lab_add_unit) {
      y_lab <- paste0(y_lab, " (", unique(df[[y_unit]]), ")")
    }

    y_lab <- trimws(y_lab)
  }

  # subtitle
  if (!is.null(subtitle)) {
    if (subtitle_add_paramcd) {
      subtitle <- paste(subtitle, unique(df[[paramcd]]))
    }

    if (subtitle_add_unit) {
      subtitle <- paste0(subtitle, " (", unique(df[[y_unit]]), ")")
    }

    subtitle <- trimws(subtitle)
  }

  ############################### |
  # ---- Build plot object. ----
  ############################### |
  p <- ggplot2::ggplot(
    data = df_stats,
    mapping = ggplot2::aes(
      x = .data[[x]], y = .data[[mid]],
      color = if (is.null(strata_N)) NULL else .data[[strata_N]],
      shape = if (is.null(strata_N)) NULL else .data[[strata_N]],
      lty = if (is.null(strata_N)) NULL else .data[[strata_N]],
      group = if (is.null(strata_N)) NULL else .data[[strata_N]]
    )
  )

  if (!is.null(mid)) {
    # points
    if (grepl("p", mid_type, fixed = TRUE)) {
      p <- p + ggplot2::geom_point(position = position, size = mid_point_size, na.rm = TRUE)
    }

    # lines
    # further conditions in if are to ensure that not all of the groups consist of only one observation
    if (grepl("l", mid_type, fixed = TRUE) &&
      !is.null(strata) &&
      !all(dplyr::summarise(df_grp, count_n = dplyr::n())[["count_n"]] == 1L)) {
      p <- p + ggplot2::geom_line(position = position, na.rm = TRUE)
    }
  }

  # interval
  if (!is.null(interval)) {
    p <- p +
      ggplot2::geom_errorbar(
        ggplot2::aes(ymin = .data[[whiskers[1]]], ymax = .data[[whiskers[max(1, length(whiskers))]]]),
        width = 0.45,
        position = position
      )

    if (length(whiskers) == 1) { # lwr or upr only; mid is then required
      # workaround as geom_errorbar does not provide single-direction whiskers
      p <- p +
        ggplot2::geom_linerange(
          data = df_stats[!is.na(df_stats[[whiskers]]), ], # as na.rm =TRUE does not suppress warnings
          ggplot2::aes(ymin = .data[[mid]], ymax = .data[[whiskers]]),
          position = position,
          na.rm = TRUE,
          show.legend = FALSE
        )
    }
  }

  p <- p +
    ggplot2::scale_y_continuous(labels = scales::comma, expand = ggplot2::expansion(c(0.25, .25))) +
    ggplot2::labs(
      title = title,
      subtitle = subtitle,
      caption = caption,
      color = legend_title,
      lty = legend_title,
      shape = legend_title,
      x = attr(df[[x]], "label"),
      y = y_lab
    )

  if (!is.null(col)) {
    p <- p +
      ggplot2::scale_color_manual(values = col)
  }

  if (!is.null(ggtheme)) {
    p <- p + ggtheme
  } else {
    p <- p +
      ggplot2::theme_bw() +
      ggplot2::theme(
        legend.key.width = grid::unit(1, "cm"),
        legend.position = legend_position,
        legend.direction = ifelse(
          legend_position %in% c("top", "bottom"),
          "horizontal",
          "vertical"
        )
      )
  }

  ############################################################# |
  # ---- Optionally, add table to the bottom of the plot. ----
  ############################################################# |
  if (!is.null(table)) {
    df_stats_table <- df_grp %>%
      dplyr::summarise(
        h_format_row(
          x = sfun(.data[[y]], ...)[table],
          format = table_format,
          labels = table_labels
        ),
        .groups = "drop"
      )

    stats_lev <- rev(setdiff(colnames(df_stats_table), c(strata, x)))

    df_stats_table <- df_stats_table %>%
      tidyr::pivot_longer(
        cols = -dplyr::all_of(c(strata, x)),
        names_to = "stat",
        values_to = "value",
        names_ptypes = list(stat = factor(levels = stats_lev))
      )

    tbl <- ggplot2::ggplot(
      df_stats_table,
      ggplot2::aes(x = .data[[x]], y = .data[["stat"]], label = .data[["value"]])
    ) +
      ggplot2::geom_text(size = table_font_size) +
      ggplot2::theme_bw() +
      ggplot2::theme(
        panel.border = ggplot2::element_blank(),
        panel.grid.major = ggplot2::element_blank(),
        panel.grid.minor = ggplot2::element_blank(),
        axis.ticks = ggplot2::element_blank(),
        axis.title = ggplot2::element_blank(),
        axis.text.x = ggplot2::element_blank(),
        axis.text.y = ggplot2::element_text(margin = ggplot2::margin(t = 0, r = 0, b = 0, l = 5)),
        strip.text = ggplot2::element_text(hjust = 0),
        strip.text.x = ggplot2::element_text(margin = ggplot2::margin(1.5, 0, 1.5, 0, "pt")),
        strip.background = ggplot2::element_rect(fill = "grey95", color = NA),
        legend.position = "none"
      )

    if (!is.null(strata)) {
      tbl <- tbl + ggplot2::facet_wrap(facets = strata, ncol = 1)
    }

    # align plot and table
    cowplot::plot_grid(p, tbl, ncol = 1)
  } else {
    p
  }
}

#' Helper function to get the right formatting in the optional table in g_lineplot.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @param x (named `list`)\cr list of numerical values to be formatted and optionally labeled.
#' Elements of `x` must be `numeric` vectors.
#' @param format (named `character` or `NULL`)\cr
#' format patterns for `x`. Names of the `format` must match the names of `x`.
#' This parameter is passed directly to the `rtables::format_rcell`
#' function through the `format` parameter.
#' @param labels (named `character` or `NULL`)\cr
#' optional labels for `x`. Names of the `labels` must match the names of `x`.
#' When a label is not specified for an element of `x`,
#' then this function tries to use `label` or `names` (in this order) attribute of that element
#' (depending on which one exists and it is not `NULL` or `NA` or `NaN`).
#' If none of these attributes are attached to a given element of `x`,
#' then the label is automatically generated.
#'
#' @author Wojciech Wojciak wojciech.wojciak@contractors.roche.com
#'
#' @return 1-row \code{data.frame} object
#'
#' @examples
#'
#' mean_ci <- c(48, 51)
#' x <- list(mean = 50, mean_ci = mean_ci)
#' format <- c(mean = "xx.x", mean_ci = "(xx.xx, xx.xx)")
#' labels <- c(mean = "My Mean")
#' h_format_row(x, format, labels)
#'
#' attr(mean_ci, "label") <- "Mean 95% CI"
#' x <- list(mean = 50, mean_ci = mean_ci)
#' h_format_row(x, format, labels)
#'
#' @export
h_format_row <- function(x, format, labels = NULL) {
  # cell: one row, one column data.frame
  format_cell <- function(x, format, label = NULL) {
    fc <- format_rcell(x = x, format = format)
    if (is.na(fc)) {
      fc <- "NA"
    }
    x_label <- attr(x, "label")
    if (!is.null(label) && !is.na(label)) {
      names(fc) <- label
    } else if (!is.null(x_label) && !is.na(x_label)) {
      names(fc) <- x_label
    } else if (length(x) == length(fc)) {
      names(fc) <- names(x)
    }
    as.data.frame(t(fc))
  }

  row <- do.call(
    cbind,
    lapply(
      names(x), function(xn) format_cell(x[[xn]], format = format[xn], label = labels[xn])
    )
  )

  row
}

#' Control Function for g_lineplot Function
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Default values for `variables` parameter in `g_lineplot` function.
#' A variable's default value can be overwritten for any variable.
#'
#' @param x (`character`)\cr x variable name.
#' @param y (`character`)\cr y variable name.
#' @param strata (`character` or `NA`)\cr strata variable name.
#' @param paramcd (`character` or `NA`)\cr paramcd variable name.
#' @param y_unit (`character` or `NA`)\cr y_unit variable name.
#'
#' @return A named character vector with names of variables.
#'
#' @author Wojciech Wojciak wojciech.wojciak@contractors.roche.com
#'
#' @export
#'
#' @examples
#' control_lineplot_vars()
#' control_lineplot_vars(strata = NA)
control_lineplot_vars <- function(x = "AVISIT", y = "AVAL", strata = "ARM", paramcd = "PARAMCD", y_unit = "AVALU") {
  checkmate::assert_string(x)
  checkmate::assert_string(y)
  checkmate::assert_string(strata, na.ok = TRUE)
  checkmate::assert_string(paramcd, na.ok = TRUE)
  checkmate::assert_string(y_unit, na.ok = TRUE)

  variables <- c(x = x, y = y, strata = strata, paramcd = paramcd, y_unit = y_unit)
  return(variables)
}

#' Proportion Difference
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @inheritParams argument_convention
#'
#' @seealso [d_proportion_diff()]
#'
#' @name prop_diff
NULL

#' @describeIn prop_diff Statistics function estimating the difference
#'   in terms of responder proportion.
#'
#' @inheritParams prop_diff_strat_nc
#' @param method (`string`)\cr the method used for the confidence interval estimation.
#'
#' @examples
#' # Summary
#'
#' ## "Mid" case: 4/4 respond in group A, 1/2 respond in group B.
#' nex <- 100 # Number of example rows
#' dta <- data.frame(
#'   "rsp" = sample(c(TRUE, FALSE), nex, TRUE),
#'   "grp" = sample(c("A", "B"), nex, TRUE),
#'   "f1" = sample(c("a1", "a2"), nex, TRUE),
#'   "f2" = sample(c("x", "y", "z"), nex, TRUE),
#'   stringsAsFactors = TRUE
#' )
#'
#' s_proportion_diff(
#'   df = subset(dta, grp == "A"),
#'   .var = "rsp",
#'   .ref_group = subset(dta, grp == "B"),
#'   .in_ref_col = FALSE,
#'   conf_level = 0.90,
#'   method = "ha"
#' )
#'
#' # CMH example with strata
#' s_proportion_diff(
#'   df = subset(dta, grp == "A"),
#'   .var = "rsp",
#'   .ref_group = subset(dta, grp == "B"),
#'   .in_ref_col = FALSE,
#'   variables = list(strata = c("f1", "f2")),
#'   conf_level = 0.90,
#'   method = "cmh"
#' )
#'
#' @export
s_proportion_diff <- function(df,
                              .var,
                              .ref_group,
                              .in_ref_col,
                              variables = list(strata = NULL),
                              conf_level = 0.95,
                              method = c(
                                "waldcc", "wald", "cmh",
                                "ha", "newcombe", "newcombecc",
                                "strat_newcombe", "strat_newcombecc"
                              ),
                              weights_method = "cmh") {
  method <- match.arg(method)
  y <- list(diff = "", diff_ci = "")

  if (!.in_ref_col) {
    rsp <- c(.ref_group[[.var]], df[[.var]])
    grp <- factor(
      rep(
        c("ref", "Not-ref"),
        c(nrow(.ref_group), nrow(df))
      ),
      levels = c("ref", "Not-ref")
    )

    if (!is.null(variables$strata)) {
      strata_colnames <- variables$strata
      checkmate::assert_character(strata_colnames, null.ok = FALSE)
      strata_vars <- stats::setNames(as.list(strata_colnames), strata_colnames)

      assert_df_with_variables(df, strata_vars)
      assert_df_with_variables(.ref_group, strata_vars)

      # Merging interaction strata for reference group rows data and remaining
      strata <- c(
        interaction(.ref_group[strata_colnames]),
        interaction(df[strata_colnames])
      )
      strata <- as.factor(strata)
    }

    # Defining the std way to calculate weights for strat_newcombe
    if (!is.null(variables$weights_method)) {
      weights_method <- variables$weights_method
    } else {
      weights_method <- "cmh"
    }

    y <- switch(method,
      "wald" = prop_diff_wald(rsp, grp, conf_level, correct = FALSE),
      "waldcc" = prop_diff_wald(rsp, grp, conf_level, correct = TRUE),
      "ha" = prop_diff_ha(rsp, grp, conf_level),
      "newcombe" = prop_diff_nc(rsp, grp, conf_level, correct = FALSE),
      "newcombecc" = prop_diff_nc(rsp, grp, conf_level, correct = TRUE),
      "strat_newcombe" = prop_diff_strat_nc(rsp,
        grp,
        strata,
        weights_method,
        conf_level,
        correct = FALSE
      ),
      "strat_newcombecc" = prop_diff_strat_nc(rsp,
        grp,
        strata,
        weights_method,
        conf_level,
        correct = TRUE
      ),
      "cmh" = prop_diff_cmh(rsp, grp, strata, conf_level)[c("diff", "diff_ci")]
    )

    y$diff <- y$diff * 100
    y$diff_ci <- y$diff_ci * 100
  }

  attr(y$diff, "label") <- "Difference in Response rate (%)"
  attr(y$diff_ci, "label") <- d_proportion_diff(
    conf_level, method,
    long = FALSE
  )

  y
}

#' @describeIn prop_diff Formatted Analysis function which can be further customized by calling
#'   [rtables::make_afun()] on it. It is used as `afun` in [rtables::analyze()].
#'
#' @examples
#' a_proportion_diff(
#'   df = subset(dta, grp == "A"),
#'   .var = "rsp",
#'   .ref_group = subset(dta, grp == "B"),
#'   .in_ref_col = FALSE,
#'   conf_level = 0.90,
#'   method = "ha"
#' )
#'
#' @export
a_proportion_diff <- make_afun(
  s_proportion_diff,
  .formats = c(diff = "xx.x", diff_ci = "(xx.x, xx.x)"),
  .indent_mods = c(diff = 0L, diff_ci = 1L)
)

#' @describeIn prop_diff Adds a descriptive analyze layer to `rtables`
#'   pipelines. The analysis is applied to a `dataframe` and return the
#'   estimations, in `rcells`. The ellipsis (`...`) conveys arguments to
#'   `s_proportion_diff()`, for instance `na.rm = FALSE` if missing data
#'   should be accounted for.
#' @inheritParams rtables::analyze
#' @param ... arguments passed to `s_proportion_diff()`.
#'
#' @examples
#' l <- basic_table() %>%
#'   split_cols_by(var = "grp", ref_group = "B") %>%
#'   estimate_proportion_diff(
#'     vars = "rsp",
#'     conf_level = 0.90,
#'     method = "ha"
#'   )
#'
#' build_table(l, df = dta)
#'
#' @export
estimate_proportion_diff <- function(lyt,
                                     vars,
                                     ...,
                                     var_labels = vars,
                                     show_labels = "hidden",
                                     table_names = vars,
                                     .stats = NULL,
                                     .formats = NULL,
                                     .labels = NULL,
                                     .indent_mods = NULL) {
  afun <- make_afun(
    a_proportion_diff,
    .stats = .stats,
    .formats = .formats,
    .labels = .labels,
    .indent_mods = .indent_mods
  )

  analyze(
    lyt,
    vars,
    afun = afun,
    var_labels = var_labels,
    extra_args = list(...),
    show_labels = show_labels,
    table_names = table_names
  )
}

#' Check: Proportion Difference Arguments
#'
#' Verifies that and/or convert arguments into valid values to be used in the
#' estimation of difference in responder proportions.
#'
#' @inheritParams prop_diff
#' @inheritParams prop_diff_wald
#'
#' @keywords internal
check_diff_prop_ci <- function(rsp,
                               grp,
                               strata = NULL,
                               conf_level,
                               correct = NULL) {
  checkmate::assert_logical(rsp, any.missing = FALSE)
  checkmate::assert_factor(grp, len = length(rsp), any.missing = FALSE, n.levels = 2)
  checkmate::assert_number(conf_level, lower = 0, upper = 1)
  checkmate::assert_flag(correct, null.ok = TRUE)

  if (!is.null(strata)) {
    checkmate::assert_factor(strata, len = length(rsp))
  }

  invisible()
}

#' Description of Method Used for Proportion Comparison
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This is an auxiliary function that describes the analysis in
#' `s_proportion_diff`.
#'
#' @inheritParams s_proportion_diff
#' @param long (`logical`)\cr Whether a long or a short (default) description is required.
#' @return String describing the analysis.
#' @seealso [prop_diff]
#'
#' @export
d_proportion_diff <- function(conf_level,
                              method,
                              long = FALSE) {
  label <- paste0(conf_level * 100, "% CI")
  if (long) {
    label <- paste(
      label,
      ifelse(
        method == "cmh",
        "for adjusted difference",
        "for difference"
      )
    )
  }

  method_part <- switch(method,
    "cmh" = "CMH, without correction",
    "waldcc" = "Wald, with correction",
    "wald" = "Wald, without correction",
    "ha" = "Anderson-Hauck",
    "newcombe" = "Newcombe, without correction",
    "newcombecc" = "Newcombe, with correction",
    "strat_newcombe" = "Stratified Newcombe, without correction",
    "strat_newcombecc" = "Stratified Newcombe, with correction",
    stop(paste(method, "does not have a description"))
  )
  paste0(label, " (", method_part, ")")
}

#' Helper Functions to Calculate Proportion Difference
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @inheritParams argument_convention
#' @inheritParams prop_diff
#' @param grp (`factor`)\cr vector assigning observations to one out of two groups
#'   (e.g. reference and treatment group).
#'
#' @seealso [prop_diff()] for implementation of these helper functions.
#'
#' @name h_prop_diff
NULL

#' @describeIn h_prop_diff The Wald interval follows the usual textbook
#'   definition for a single proportion confidence interval using the normal
#'   approximation. It is possible to include a continuity correction for Wald's
#'   interval.
#'
#' @param correct `logical`\cr include the continuity correction. For further
#'   information, see [stats::prop.test()].
#'
#' @examples
#' # Wald confidence interval
#' set.seed(2)
#' rsp <- sample(c(TRUE, FALSE), replace = TRUE, size = 20)
#' grp <- factor(c(rep("A", 10), rep("B", 10)))
#' prop_diff_wald(rsp = rsp, grp = grp, conf_level = 0.95, correct = FALSE)
#'
#' @export
prop_diff_wald <- function(rsp,
                           grp,
                           conf_level = 0.95,
                           correct = FALSE) {
  if (isTRUE(correct)) {
    mthd <- "waldcc"
  } else {
    mthd <- "wald"
  }
  grp <- as_factor_keep_attributes(grp)
  check_diff_prop_ci(
    rsp = rsp, grp = grp, conf_level = conf_level, correct = correct
  )

  # check if binary response is coded as logical
  checkmate::assert_logical(rsp, any.missing = FALSE)
  checkmate::assert_factor(grp, len = length(rsp), any.missing = FALSE, n.levels = 2)

  tbl <- table(grp, factor(rsp, levels = c(TRUE, FALSE)))
  # x1 and n1 are non-reference groups.
  diff_ci <- desctools_binom(
    x1 = tbl[2], n1 = sum(tbl[2], tbl[4]),
    x2 = tbl[1], n2 = sum(tbl[1], tbl[3]),
    conf.level = conf_level,
    method = mthd
  )

  list(
    "diff" = unname(diff_ci[, "est"]),
    "diff_ci" = unname(diff_ci[, c("lwr.ci", "upr.ci")])
  )
}

#' @describeIn h_prop_diff Anderson-Hauck confidence interval.
#'
#' @examples
#' # Anderson-Hauck confidence interval
#' ## "Mid" case: 3/4 respond in group A, 1/2 respond in group B.
#' rsp <- c(TRUE, FALSE, FALSE, TRUE, TRUE, TRUE)
#' grp <- factor(c("A", "B", "A", "B", "A", "A"), levels = c("B", "A"))
#' prop_diff_ha(rsp = rsp, grp = grp, conf_level = 0.90)
#'
#' ## Edge case: Same proportion of response in A and B.
#' rsp <- c(TRUE, FALSE, TRUE, FALSE)
#' grp <- factor(c("A", "A", "B", "B"), levels = c("A", "B"))
#' prop_diff_ha(rsp = rsp, grp = grp, conf_level = 0.6)
#'
#' @export
prop_diff_ha <- function(rsp,
                         grp,
                         conf_level) {
  grp <- as_factor_keep_attributes(grp)
  check_diff_prop_ci(rsp = rsp, grp = grp, conf_level = conf_level)

  tbl <- table(grp, factor(rsp, levels = c(TRUE, FALSE)))
  # x1 and n1 are non-reference groups.
  ci <- desctools_binom(
    x1 = tbl[2], n1 = sum(tbl[2], tbl[4]),
    x2 = tbl[1], n2 = sum(tbl[1], tbl[3]),
    conf.level = conf_level,
    method = "ha"
  )
  list(
    "diff" = unname(ci[, "est"]),
    "diff_ci" = unname(ci[, c("lwr.ci", "upr.ci")])
  )
}




#' @describeIn h_prop_diff Newcombe confidence interval. It is based on
#'   the Wilson score confidence interval for a single binomial proportion.
#'
#' @examples
#' # Newcombe confidence interval
#'
#' set.seed(1)
#' rsp <- c(
#'   sample(c(TRUE, FALSE), size = 40, prob = c(3 / 4, 1 / 4), replace = TRUE),
#'   sample(c(TRUE, FALSE), size = 40, prob = c(1 / 2, 1 / 2), replace = TRUE)
#' )
#' grp <- factor(rep(c("A", "B"), each = 40), levels = c("B", "A"))
#' table(rsp, grp)
#' prop_diff_nc(rsp = rsp, grp = grp, conf_level = 0.9)
#'
#' @export
prop_diff_nc <- function(rsp,
                         grp,
                         conf_level,
                         correct = FALSE) {
  if (isTRUE(correct)) {
    mthd <- "scorecc"
  } else {
    mthd <- "score"
  }
  grp <- as_factor_keep_attributes(grp)
  check_diff_prop_ci(rsp = rsp, grp = grp, conf_level = conf_level)

  p_grp <- tapply(rsp, grp, mean)
  diff_p <- unname(diff(p_grp))
  tbl <- table(grp, factor(rsp, levels = c(TRUE, FALSE)))
  ci <- desctools_binom(
    # x1 and n1 are non-reference groups.
    x1 = tbl[2], n1 = sum(tbl[2], tbl[4]),
    x2 = tbl[1], n2 = sum(tbl[1], tbl[3]),
    conf.level = conf_level,
    method = mthd
  )
  list(
    "diff" = unname(ci[, "est"]),
    "diff_ci" = unname(ci[, c("lwr.ci", "upr.ci")])
  )
}


#' @describeIn h_prop_diff Calculates the weighted difference.
#'   This is defined as the difference in response rates between the
#'   experimental treatment group and the control treatment group, adjusted
#'   for stratification factors by applying Cochran-Mantel-Haenszel (CMH)
#'   weights. For the CMH chi-squared test, use [stats::mantelhaen.test()].
#'
#' @param strata (`factor`)\cr variable with one level per stratum and same length as `rsp`.
#'
#' @examples
#' # Cochran-Mantel-Haenszel confidence interval
#'
#' set.seed(2)
#' rsp <- sample(c(TRUE, FALSE), 100, TRUE)
#' grp <- sample(c("Placebo", "Treatment"), 100, TRUE)
#' grp <- factor(grp, levels = c("Placebo", "Treatment"))
#' strata_data <- data.frame(
#'   "f1" = sample(c("a", "b"), 100, TRUE),
#'   "f2" = sample(c("x", "y", "z"), 100, TRUE),
#'   stringsAsFactors = TRUE
#' )
#'
#' prop_diff_cmh(
#'   rsp = rsp, grp = grp, strata = interaction(strata_data),
#'   conf_level = 0.90
#' )
#'
#' @export
prop_diff_cmh <- function(rsp,
                          grp,
                          strata,
                          conf_level = 0.95) {
  grp <- as_factor_keep_attributes(grp)
  strata <- as_factor_keep_attributes(strata)
  check_diff_prop_ci(
    rsp = rsp, grp = grp, conf_level = conf_level, strata = strata
  )

  if (any(tapply(rsp, strata, length) < 5)) {
    warning("Less than 5 observations in some strata.")
  }

  # first dimension: FALSE, TRUE
  # 2nd dimension: CONTROL, TX
  # 3rd dimension: levels of strat
  # rsp as factor rsp to handle edge case of no FALSE (or TRUE) rsp records
  t_tbl <- table(
    factor(rsp, levels = c("FALSE", "TRUE")),
    grp,
    strata
  )
  n1 <- colSums(t_tbl[1:2, 1, ])
  n2 <- colSums(t_tbl[1:2, 2, ])
  p1 <- t_tbl[2, 1, ] / n1
  p2 <- t_tbl[2, 2, ] / n2
  # CMH weights
  use_stratum <- (n1 > 0) & (n2 > 0)
  n1 <- n1[use_stratum]
  n2 <- n2[use_stratum]
  p1 <- p1[use_stratum]
  p2 <- p2[use_stratum]
  wt <- (n1 * n2 / (n1 + n2))
  wt_normalized <- wt / sum(wt)
  est1 <- sum(wt_normalized * p1)
  est2 <- sum(wt_normalized * p2)
  estimate <- c(est1, est2)
  names(estimate) <- levels(grp)
  se1 <- sqrt(sum(wt_normalized^2 * p1 * (1 - p1) / n1))
  se2 <- sqrt(sum(wt_normalized^2 * p2 * (1 - p2) / n2))
  z <- stats::qnorm((1 + conf_level) / 2)
  err1 <- z * se1
  err2 <- z * se2
  ci1 <- c((est1 - err1), (est1 + err1))
  ci2 <- c((est2 - err2), (est2 + err2))
  estimate_ci <- list(ci1, ci2)
  names(estimate_ci) <- levels(grp)
  diff_est <- est2 - est1
  se_diff <- sqrt(sum(((p1 * (1 - p1) / n1) + (p2 * (1 - p2) / n2)) * wt_normalized^2))
  diff_ci <- c(diff_est - z * se_diff, diff_est + z * se_diff)

  list(
    prop = estimate,
    prop_ci = estimate_ci,
    diff = diff_est,
    diff_ci = diff_ci,
    weights = wt_normalized,
    n1 = n1,
    n2 = n2
  )
}

#' @describeIn h_prop_diff Calculates the stratified Newcombe confidence interval
#'   and difference in response rates between the experimental treatment group
#'   and the control treatment group, adjusted for stratification factors. This
#'   implementation follows closely the one proposed by
#'   \insertCite{Yan2010-jt;textual}{tern}. Weights can be estimated from the
#'   heuristic proposed in [prop_strat_wilson()] or from CMH-derived weights
#'   (see [prop_diff_cmh()]).
#'
#' @param strata (`factor`)\cr variable with one level per stratum and same length as `rsp`.
#' @param weights_method (`string`)\cr weights method. Can be either `"cmh"` or `"heuristic"`
#'   and directs the way weights are estimated.
#'
#' @examples
#' # Stratified Newcombe confidence interval
#'
#' set.seed(2)
#' data_set <- data.frame(
#'   "rsp" = sample(c(TRUE, FALSE), 100, TRUE),
#'   "f1" = sample(c("a", "b"), 100, TRUE),
#'   "f2" = sample(c("x", "y", "z"), 100, TRUE),
#'   "grp" = sample(c("Placebo", "Treatment"), 100, TRUE),
#'   stringsAsFactors = TRUE
#' )
#'
#' prop_diff_strat_nc(
#'   rsp = data_set$rsp, grp = data_set$grp, strata = interaction(data_set[2:3]),
#'   weights_method = "cmh",
#'   conf_level = 0.90
#' )
#'
#' prop_diff_strat_nc(
#'   rsp = data_set$rsp, grp = data_set$grp, strata = interaction(data_set[2:3]),
#'   weights_method = "wilson_h",
#'   conf_level = 0.90
#' )
#'
#' @references
#' - \insertRef{Yan2010-jt}{tern}
#'
#' @importFrom Rdpack reprompt
#'
#' @export
prop_diff_strat_nc <- function(rsp,
                               grp,
                               strata,
                               weights_method = c("cmh", "wilson_h"),
                               conf_level = 0.95,
                               correct = FALSE) {
  weights_method <- match.arg(weights_method)
  grp <- as_factor_keep_attributes(grp)
  strata <- as_factor_keep_attributes(strata)
  check_diff_prop_ci(
    rsp = rsp, grp = grp, conf_level = conf_level, strata = strata
  )
  checkmate::assert_number(conf_level, lower = 0, upper = 1)
  checkmate::assert_flag(correct)
  if (any(tapply(rsp, strata, length) < 5)) {
    warning("Less than 5 observations in some strata.")
  }

  rsp_by_grp <- split(rsp, f = grp)
  strata_by_grp <- split(strata, f = grp)

  # Finding the weights
  weights <- if (identical(weights_method, "cmh")) {
    prop_diff_cmh(rsp = rsp, grp = grp, strata = strata)$weights
  } else if (identical(weights_method, "wilson_h")) {
    prop_strat_wilson(rsp, strata, conf_level = conf_level, correct = correct)$weights
  }
  weights[levels(strata)[!levels(strata) %in% names(weights)]] <- 0

  # Calculating lower (`l`) and upper (`u`) confidence bounds per group.
  strat_wilson_by_grp <- Map(
    prop_strat_wilson,
    rsp = rsp_by_grp,
    strata = strata_by_grp,
    weights = list(weights, weights),
    conf_level = conf_level,
    correct = correct
  )

  ci_ref <- strat_wilson_by_grp[[1]]
  ci_trt <- strat_wilson_by_grp[[2]]
  l_ref <- as.numeric(ci_ref$conf_int[1])
  u_ref <- as.numeric(ci_ref$conf_int[2])
  l_trt <- as.numeric(ci_trt$conf_int[1])
  u_trt <- as.numeric(ci_trt$conf_int[2])

  # Estimating the diff and n_ref, n_trt (it allows different weights to be used)
  t_tbl <- table(
    factor(rsp, levels = c("FALSE", "TRUE")),
    grp,
    strata
  )
  n_ref <- colSums(t_tbl[1:2, 1, ])
  n_trt <- colSums(t_tbl[1:2, 2, ])
  use_stratum <- (n_ref > 0) & (n_trt > 0)
  n_ref <- n_ref[use_stratum]
  n_trt <- n_trt[use_stratum]
  p_ref <- t_tbl[2, 1, use_stratum] / n_ref
  p_trt <- t_tbl[2, 2, use_stratum] / n_trt
  est1 <- sum(weights * p_ref)
  est2 <- sum(weights * p_trt)
  diff_est <- est2 - est1

  lambda1 <- sum(weights^2 / n_ref)
  lambda2 <- sum(weights^2 / n_trt)
  z <- stats::qnorm((1 + conf_level) / 2)

  lower <- diff_est - z * sqrt(lambda2 * l_trt * (1 - l_trt) + lambda1 * u_ref * (1 - u_ref))
  upper <- diff_est + z * sqrt(lambda1 * l_ref * (1 - l_ref) + lambda2 * u_trt * (1 - u_trt))

  list(
    "diff" = diff_est,
    "diff_ci" = c("lower" = lower, "upper" = upper)
  )
}

#' Cox Proportional Hazards Regression
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Fits a Cox regression model and estimate hazard ratio to describe the effect
#' size in a survival analysis.
#'
#' @details
#' Cox models are the most commonly used methods to estimate the magnitude of
#' the effect in survival analysis. It assumes proportional hazards: the ratio
#' of the hazards between groups (e.g., two arms) is constant over time.
#' This ratio is referred to as the "hazard ratio" (HR) and is one of the
#' most commonly reported metrics to describe the effect size in survival
#' analysis (NEST Team, 2020).
#'
#' @note The usual formatting arguments for the _layout creating_ function
#'  `summarize_coxreg` are not yet accepted (`.stats`, `.indent_mod`, `.formats`,
#'  `.labels`).
#' @inheritParams argument_convention
#' @seealso [fit_coxreg] for relevant fitting functions, [h_cox_regression] for relevant
#' helper functions, and [tidy_coxreg] for custom tidy methods.
#'
#' @name cox_regression
#'
#' @examples
#' library(survival)
#'
#' # Testing dataset [survival::bladder].
#' set.seed(1, kind = "Mersenne-Twister")
#' dta_bladder <- with(
#'   data = bladder[bladder$enum < 5, ],
#'   data.frame(
#'     time = stop,
#'     status = event,
#'     armcd = as.factor(rx),
#'     covar1 = as.factor(enum),
#'     covar2 = factor(
#'       sample(as.factor(enum)),
#'       levels = 1:4, labels = c("F", "F", "M", "M")
#'     )
#'   )
#' )
#' labels <- c("armcd" = "ARM", "covar1" = "A Covariate Label", "covar2" = "Sex (F/M)")
#' formatters::var_labels(dta_bladder)[names(labels)] <- labels
#' dta_bladder$age <- sample(20:60, size = nrow(dta_bladder), replace = TRUE)
#'
#' plot(
#'   survfit(Surv(time, status) ~ armcd + covar1, data = dta_bladder),
#'   lty = 2:4,
#'   xlab = "Months",
#'   col = c("blue1", "blue2", "blue3", "blue4", "red1", "red2", "red3", "red4")
#' )
NULL

#' @describeIn cox_regression transforms the tabulated results from [`fit_coxreg_univar()`]
#'  and [`fit_coxreg_multivar()`] into a list. Not much calculation is done here,
#'  it rather prepares the data to be used by the layout creating function.
#' @export
#'
#' @examples
#' # s_coxreg
#'
#' univar_model <- fit_coxreg_univar(
#'   variables = list(
#'     time = "time", event = "status", arm = "armcd",
#'     covariates = c("covar1", "covar2")
#'   ),
#'   data = dta_bladder
#' )
#' df1 <- broom::tidy(univar_model)
#' s_coxreg(df = df1, .var = "hr")
#'
#' # Only covariates.
#' univar_covs_model <- fit_coxreg_univar(
#'   variables = list(
#'     time = "time", event = "status",
#'     covariates = c("covar1", "covar2")
#'   ),
#'   data = dta_bladder
#' )
#' df1_covs <- broom::tidy(univar_covs_model)
#' s_coxreg(df = df1_covs, .var = "hr")
#'
#' # Multivariate.
#' multivar_model <- fit_coxreg_multivar(
#'   variables = list(
#'     time = "time", event = "status", arm = "armcd",
#'     covariates = c("covar1", "covar2")
#'   ),
#'   data = dta_bladder
#' )
#' df2 <- broom::tidy(multivar_model)
#' s_coxreg(df = df2, .var = "hr")
#'
#' # Multivariate without treatment arm.
#' multivar_covs_model <- fit_coxreg_multivar(
#'   variables = list(
#'     time = "time", event = "status",
#'     covariates = c("covar1", "covar2")
#'   ),
#'   data = dta_bladder
#' )
#' df2_covs <- broom::tidy(multivar_covs_model)
#' s_coxreg(df = df2_covs, .var = "hr")
s_coxreg <- function(df, .var) {
  assert_df_with_variables(df, list(term = "term", var = .var))
  checkmate::assert_multi_class(df$term, classes = c("factor", "character"))
  df$term <- as.character(df$term)
  # We need a list with names corresponding to the stats to display.
  # There can be several covariate to test, but the names of the items should
  # be constant and equal to the stats to display.
  y <- split(df, f = df$term, drop = FALSE)
  y <- stats::setNames(y, nm = rep(.var, length(y)))
  lapply(
    X = y,
    FUN = function(x) {
      z <- as.list(x[[.var]])
      stats::setNames(z, nm = x$term_label)
    }
  )
}

#' @describeIn cox_regression layout creating function.
#' @inheritParams argument_convention
#' @inheritParams control_coxreg
#' @param multivar (`flag`)\cr if `TRUE`, the multi-variable Cox regression will run
#'   and no interaction will be considered between the studied treatment and c
#'   candidate covariate. Default is `FALSE` for univariate Cox regression including
#'   an arm variable. When no arm variable is included in the univariate Cox regression,
#'   then also `TRUE` should be used to tabulate the covariate effect estimates instead
#'   of the treatment arm effect estimate across models.
#' @param vars (`character`)\cr the name of statistics to be reported among
#'  `n` (number of observation),
#'  `hr` (Hazard Ratio),
#'  `ci` (confidence interval),
#'  `pval` (p.value of the treatment effect) and
#'  `pval_inter` (the p.value of the interaction effect between the treatment
#'  and the covariate).
#' @export
#'
#' @examples
#' # summarize_coxreg
#' result_univar <- basic_table() %>%
#'   split_rows_by("effect") %>%
#'   split_rows_by("term", child_labels = "hidden") %>%
#'   summarize_coxreg(conf_level = 0.95) %>%
#'   build_table(df1)
#' result_univar
#'
#' result_multivar <- basic_table() %>%
#'   split_rows_by("term", child_labels = "hidden") %>%
#'   summarize_coxreg(multivar = TRUE, conf_level = .95) %>%
#'   build_table(df2)
#' result_multivar
#'
#' # When tabulating univariate models with only covariates, also `multivar = TRUE`
#' # is used.
#' result_univar_covs <- basic_table() %>%
#'   split_rows_by("term", child_labels = "hidden") %>%
#'   summarize_coxreg(multivar = TRUE, conf_level = 0.95) %>%
#'   build_table(df1_covs)
#' result_univar_covs
#'
#' # No change for the multivariate tabulation when no treatment arm is included.
#' result_multivar_covs <- basic_table() %>%
#'   split_rows_by("term", child_labels = "hidden") %>%
#'   summarize_coxreg(multivar = TRUE, conf_level = .95) %>%
#'   build_table(df2_covs)
#' result_multivar_covs
summarize_coxreg <- function(lyt,
                             conf_level,
                             multivar = FALSE,
                             vars = c("n", "hr", "ci", "pval")) {
  afun_list <- Map(
    function(stat, format) {
      make_afun(s_coxreg, .stats = stat, .formats = format, .ungroup_stats = stat)
    },
    stat = c("n", "hr", "ci", "pval", "pval_inter"),
    format = c(
      n = "xx",
      hr = "xx.xx",
      ci = "(xx.xx, xx.xx)",
      pval = "x.xxxx | (<0.0001)",
      pval_inter = "x.xxxx | (<0.0001)"
    )
  )

  if (multivar) {
    vars <- intersect(c("hr", "ci", "pval"), vars)
    lyt <- split_cols_by_multivar(
      lyt = lyt,
      vars = vars,
      varlabels = c(
        hr = "Hazard Ratio",
        ci = paste0(100 * conf_level, "% CI"),
        pval = "p-value"
      )[vars]
    )
  } else {
    lyt <- split_cols_by_multivar(
      lyt = lyt,
      vars = vars,
      varlabels = c(
        n = "n", hr = "Hazard Ratio",
        ci = paste0(100 * conf_level, "% CI"),
        pval = "p-value",
        pval_inter = "Interaction p-value"
      )[vars]
    )
  }

  analyze_colvars(lyt = lyt, afun = afun_list[vars])
}

#' Controls for Cox Regression
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Sets a list of parameters for Cox regression fit. Used internally,
#' see [fit_coxreg_univar()] and [fit_coxreg_multivar()].
#'
#' @inheritParams argument_convention
#' @param pval_method (`string`)\cr the method used for estimation of p.values;
#'   `wald` (default) or `likelihood`.
#' @param interaction (`flag`)\cr if `TRUE`, the model includes the
#'   interaction between the studied treatment and candidate covariate. Note that
#'   for univariate models without treatment arm, and multivariate models, no
#'   interaction can be used so that this needs to be `FALSE`.
#' @param ties (`string`)\cr among `exact` (equivalent to `DISCRETE` in SAS),
#'   `efron` and `breslow`, see [survival::coxph()].
#'   Note: there is no equivalent of SAS `EXACT` method in R.
#'
#' @return A `list` of item corresponding to the arguments.
#'
#' @examples
#' control_coxreg()
#'
#' @export
control_coxreg <- function(pval_method = c("wald", "likelihood"),
                           ties = c("exact", "efron", "breslow"),
                           conf_level = 0.95,
                           interaction = FALSE) {
  pval_method <- match.arg(pval_method)
  ties <- match.arg(ties)
  checkmate::assert_flag(interaction)
  assert_proportion_value(conf_level)
  list(
    pval_method = pval_method,
    ties = ties,
    conf_level = conf_level,
    interaction = interaction
  )
}

#' Custom Tidy Methods for Cox Regression
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @seealso [cox_regression]
#'
#' @name tidy_coxreg
NULL

#' @describeIn tidy_coxreg Custom tidy method for [survival::coxph()] summary results.
#'
#' Tidy the [survival::coxph()] results into a `data.frame` to extract model results.
#'
#' @inheritParams argument_convention
#' @method tidy summary.coxph
#' @export
#'
#' @examples
#' library(survival)
#' library(broom)
#'
#' set.seed(1, kind = "Mersenne-Twister")
#'
#' dta_bladder <- with(
#'   data = bladder[bladder$enum < 5, ],
#'   data.frame(
#'     time = stop,
#'     status = event,
#'     armcd = as.factor(rx),
#'     covar1 = as.factor(enum),
#'     covar2 = factor(
#'       sample(as.factor(enum)),
#'       levels = 1:4, labels = c("F", "F", "M", "M")
#'     )
#'   )
#' )
#' labels <- c("armcd" = "ARM", "covar1" = "A Covariate Label", "covar2" = "Sex (F/M)")
#' formatters::var_labels(dta_bladder)[names(labels)] <- labels
#' dta_bladder$age <- sample(20:60, size = nrow(dta_bladder), replace = TRUE)
#'
#' formula <- "survival::Surv(time, status) ~ armcd + covar1"
#' msum <- summary(coxph(stats::as.formula(formula), data = dta_bladder))
#' tidy(msum)
tidy.summary.coxph <- function(x, # nolint
                               ...) {
  checkmate::assert_class(x, "summary.coxph")
  pval <- x$coefficients
  confint <- x$conf.int
  levels <- rownames(pval)

  pval <- tibble::as_tibble(pval)
  confint <- tibble::as_tibble(confint)

  ret <- cbind(pval[, grepl("Pr", names(pval))], confint)
  ret$level <- levels
  ret$n <- x[["n"]]
  ret
}

#' @describeIn tidy_coxreg Custom tidy method for a Univariate Cox Regression
#'
#' Tidy up the result of a Cox regression model fitted by [`fit_coxreg_univar()`].
#'
#' @inheritParams argument_convention
#' @param x (`list`)\cr Result of the Cox regression model fitted by [`fit_coxreg_univar()`].
#'
#' @method tidy coxreg.univar
#' @export
#'
#' @examples
#' ## Cox regression: arm + 1 covariate.
#' mod1 <- fit_coxreg_univar(
#'   variables = list(
#'     time = "time", event = "status", arm = "armcd",
#'     covariates = "covar1"
#'   ),
#'   data = dta_bladder,
#'   control = control_coxreg(conf_level = 0.91)
#' )
#'
#' ## Cox regression: arm + 1 covariate + interaction, 2 candidate covariates.
#' mod2 <- fit_coxreg_univar(
#'   variables = list(
#'     time = "time", event = "status", arm = "armcd",
#'     covariates = c("covar1", "covar2")
#'   ),
#'   data = dta_bladder,
#'   control = control_coxreg(conf_level = 0.91, interaction = TRUE)
#' )
#'
#' tidy(mod1)
#' tidy(mod2)
tidy.coxreg.univar <- function(x, # nolint
                               ...) {
  checkmate::assert_class(x, "coxreg.univar")
  mod <- x$mod
  vars <- c(x$vars$arm, x$vars$covariates)
  has_arm <- "arm" %in% names(x$vars)

  result <- if (!has_arm) {
    Map(
      mod = mod, vars = vars,
      f = function(mod, vars) {
        h_coxreg_multivar_extract(
          var = vars,
          data = x$data,
          mod = mod,
          control = x$control
        )
      }
    )
  } else if (x$control$interaction) {
    Map(
      mod = mod, covar = vars,
      f = function(mod, covar) {
        h_coxreg_extract_interaction(
          effect = x$vars$arm, covar = covar, mod = mod, data = x$data,
          at = x$at, control = x$control
        )
      }
    )
  } else {
    Map(
      mod = mod, vars = vars,
      f = function(mod, vars) {
        h_coxreg_univar_extract(
          effect = x$vars$arm, covar = vars, data = x$data, mod = mod,
          control = x$control
        )
      }
    )
  }
  result <- do.call(rbind, result)

  result$ci <- Map(lcl = result$lcl, ucl = result$ucl, f = function(lcl, ucl) c(lcl, ucl))
  result$n <- lapply(result$n, empty_vector_if_na)
  result$ci <- lapply(result$ci, empty_vector_if_na)
  result$hr <- lapply(result$hr, empty_vector_if_na)
  if (x$control$interaction) {
    result$pval_inter <- lapply(result$pval_inter, empty_vector_if_na)
    # Remove interaction p-values due to change in specifications.
    result$pval[result$effect != "Treatment:"] <- NA
  }
  result$pval <- lapply(result$pval, empty_vector_if_na)
  attr(result, "conf_level") <- x$control$conf_level
  result
}

#' @describeIn tidy_coxreg Custom tidy method for a Multi-variable Cox Regression
#'
#' Tidy up the result of a Cox regression model fitted by [`fit_coxreg_multivar()`].
#'
#' @inheritParams argument_convention
#' @param x (`list`)\cr Result of the Cox regression model fitted by [`fit_coxreg_multivar()`].
#'
#' @method tidy coxreg.multivar
#' @export
#'
#' @examples
#' multivar_model <- fit_coxreg_multivar(
#'   variables = list(
#'     time = "time", event = "status", arm = "armcd",
#'     covariates = c("covar1", "covar2")
#'   ),
#'   data = dta_bladder
#' )
#' broom::tidy(multivar_model)
tidy.coxreg.multivar <- function(x, # nolint
                                 ...) {
  checkmate::assert_class(x, "coxreg.multivar")
  vars <- c(x$vars$arm, x$vars$covariates)

  # Convert the model summaries to data.
  result <- Map(
    vars = vars,
    f = function(vars) {
      h_coxreg_multivar_extract(
        var = vars, data = x$data,
        mod = x$mod, control = x$control
      )
    }
  )
  result <- do.call(rbind, result)

  result$ci <- Map(lcl = result$lcl, ucl = result$ucl, f = function(lcl, ucl) c(lcl, ucl))
  result$ci <- lapply(result$ci, empty_vector_if_na)
  result$hr <- lapply(result$hr, empty_vector_if_na)
  result$pval <- lapply(result$pval, empty_vector_if_na)
  result <- result[, names(result) != "n"]
  attr(result, "conf_level") <- x$control$conf_level

  result
}

#' Fits for Cox Proportional Hazards Regression
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Fitting functions for univariate and multivariate Cox regression models.
#'
#' @seealso [h_cox_regression] for relevant helper functions, [cox_regression].
#'
#' @examples
#' library(survival)
#'
#' set.seed(1, kind = "Mersenne-Twister")
#'
#' # Testing dataset [survival::bladder].
#' dta_bladder <- with(
#'   data = bladder[bladder$enum < 5, ],
#'   data.frame(
#'     time = stop,
#'     status = event,
#'     armcd = as.factor(rx),
#'     covar1 = as.factor(enum),
#'     covar2 = factor(
#'       sample(as.factor(enum)),
#'       levels = 1:4, labels = c("F", "F", "M", "M")
#'     )
#'   )
#' )
#' labels <- c("armcd" = "ARM", "covar1" = "A Covariate Label", "covar2" = "Sex (F/M)")
#' formatters::var_labels(dta_bladder)[names(labels)] <- labels
#' dta_bladder$age <- sample(20:60, size = nrow(dta_bladder), replace = TRUE)
#'
#' plot(
#'   survfit(Surv(time, status) ~ armcd + covar1, data = dta_bladder),
#'   lty = 2:4,
#'   xlab = "Months",
#'   col = c("blue1", "blue2", "blue3", "blue4", "red1", "red2", "red3", "red4")
#' )
#'
#' @name fit_coxreg
NULL

#' @describeIn fit_coxreg Fit a series of univariate Cox regression models
#'   given the inputs.
#'
#' @param variables (`list`)\cr a named list corresponds to the names of variables found
#'   in `data`, passed as a named list and corresponding to `time`, `event`, `arm`,
#'   `strata`, and `covariates` terms. If `arm` is missing from `variables`, then
#'   only Cox model(s) including the `covariates` will be fitted and the corresponding
#'   effect estimates will be tabulated later.
#' @param data (`data.frame`)\cr the dataset containing the variables to fit the
#'   models.
#' @param at (`list` of `numeric`)\cr when the candidate covariate is a
#'  `numeric`, use `at` to specify the value of the covariate at which the
#'  effect should be estimated.
#' @param control (`list`)\cr a list of parameters as returned by the
#'   helper function [control_coxreg()].
#' @return The function `fit_coxreg_univar` returns a `coxreg.univar` class object which is a named list
#' with 5 elements:
#' \describe{
#'   \item{mod}{Cox regression models fitted by [survival::coxph()].}
#'   \item{data}{The original data frame input.}
#'   \item{control}{The original control input.}
#'   \item{vars}{The variables used in the model.}
#'   \item{at}{Value of the covariate at which the effect should be estimated.}
#' }
#' @note When using `fit_coxreg_univar` there should be two study arms.
#'
#' @examples
#' # fit_coxreg_univar
#'
#' ## Cox regression: arm + 1 covariate.
#' mod1 <- fit_coxreg_univar(
#'   variables = list(
#'     time = "time", event = "status", arm = "armcd",
#'     covariates = "covar1"
#'   ),
#'   data = dta_bladder,
#'   control = control_coxreg(conf_level = 0.91)
#' )
#'
#' ## Cox regression: arm + 1 covariate + interaction, 2 candidate covariates.
#' mod2 <- fit_coxreg_univar(
#'   variables = list(
#'     time = "time", event = "status", arm = "armcd",
#'     covariates = c("covar1", "covar2")
#'   ),
#'   data = dta_bladder,
#'   control = control_coxreg(conf_level = 0.91, interaction = TRUE)
#' )
#'
#' ## Cox regression: arm + 1 covariate, stratified analysis.
#' mod3 <- fit_coxreg_univar(
#'   variables = list(
#'     time = "time", event = "status", arm = "armcd", strata = "covar2",
#'     covariates = c("covar1")
#'   ),
#'   data = dta_bladder,
#'   control = control_coxreg(conf_level = 0.91)
#' )
#'
#' ## Cox regression: no arm, only covariates.
#' mod4 <- fit_coxreg_univar(
#'   variables = list(
#'     time = "time", event = "status",
#'     covariates = c("covar1", "covar2")
#'   ),
#'   data = dta_bladder
#' )
#'
#' @export
fit_coxreg_univar <- function(variables,
                              data,
                              at = list(),
                              control = control_coxreg()) {
  checkmate::assert_list(variables, names = "named")
  has_arm <- "arm" %in% names(variables)
  arm_name <- if (has_arm) "arm" else NULL

  checkmate::assert_character(variables$covariates, null.ok = TRUE)

  assert_df_with_variables(data, variables)
  assert_list_of_variables(variables[c(arm_name, "event", "time")])

  if (!is.null(variables$strata)) {
    checkmate::assert_disjunct(control$pval_method, "likelihood")
  }
  if (has_arm) {
    assert_df_with_factors(data, list(val = variables$arm), min.levels = 2, max.levels = 2)
  }
  vars <- unlist(variables[c(arm_name, "covariates", "strata")], use.names = FALSE)
  for (i in vars) {
    if (is.factor(data[[i]])) {
      attr(data[[i]], "levels") <- levels(droplevels(data[[i]]))
    }
  }
  forms <- h_coxreg_univar_formulas(variables, interaction = control$interaction)
  mod <- lapply(
    forms, function(x) {
      survival::coxph(formula = stats::as.formula(x), data = data, ties = control$ties)
    }
  )
  structure(
    list(
      mod = mod,
      data = data,
      control = control,
      vars = variables,
      at = at
    ),
    class = "coxreg.univar"
  )
}

#' @describeIn fit_coxreg Fit a multi-variable Cox regression model.
#'
#' @return The function `fit_coxreg_multivar` returns a `coxreg.multivar` class object which is a named list
#' with 4 elements:
#' \describe{
#'   \item{mod}{Cox regression model fitted by [survival::coxph()].}
#'   \item{data}{The original data frame input.}
#'   \item{control}{The original control input.}
#'   \item{vars}{The variables used in the model.}
#' }
#'
#' @examples
#' # fit_coxreg_multivar
#'
#' ## Cox regression: multivariate Cox regression.
#' multivar_model <- fit_coxreg_multivar(
#'   variables = list(
#'     time = "time", event = "status", arm = "armcd",
#'     covariates = c("covar1", "covar2")
#'   ),
#'   data = dta_bladder
#' )
#'
#' # Example without treatment arm.
#' multivar_covs_model <- fit_coxreg_multivar(
#'   variables = list(
#'     time = "time", event = "status",
#'     covariates = c("covar1", "covar2")
#'   ),
#'   data = dta_bladder
#' )
#'
#' @export
fit_coxreg_multivar <- function(variables,
                                data,
                                control = control_coxreg()) {
  checkmate::assert_list(variables, names = "named")
  has_arm <- "arm" %in% names(variables)
  arm_name <- if (has_arm) "arm" else NULL

  if (!is.null(variables$covariates)) {
    checkmate::assert_character(variables$covariates)
  }

  checkmate::assert_false(control$interaction)
  assert_df_with_variables(data, variables)
  assert_list_of_variables(variables[c(arm_name, "event", "time")])

  if (!is.null(variables$strata)) {
    checkmate::assert_disjunct(control$pval_method, "likelihood")
  }

  form <- h_coxreg_multivar_formula(variables)
  mod <- survival::coxph(
    formula = stats::as.formula(form),
    data = data,
    ties = control$ties
  )
  structure(
    list(
      mod = mod,
      data = data,
      control = control,
      vars = variables
    ),
    class = "coxreg.multivar"
  )
}

#' Muffled `car::Anova`
#'
#' Applied on survival models, [car::Anova()] signal that the `strata` terms is dropped from the model formula when
#' present, this function deliberately muffles this message.
#'
#' @param mod (`coxph`)\cr Cox regression model fitted by [survival::coxph()].
#' @param test_statistic (`string`)\cr the method used for estimation of p.values;
#'   `wald` (default) or `likelihood`.
#'
#' @keywords internal
muffled_car_anova <- function(mod, test_statistic) {
  tryCatch(
    withCallingHandlers(
      expr = {
        car::Anova(
          mod,
          test.statistic = test_statistic,
          type = "III"
        )
      },
      message = function(m) invokeRestart("muffleMessage"),
      error = function(e) {
        stop(paste(
          "the model seems to have convergence problems, please try to change",
          "the configuration of covariates or strata variables, e.g.",
          "- original error:", e
        ))
      }
    )
  )
}

#' Pairwise Formula Special Term
#'
#' @description `r lifecycle::badge("stable")`
#'
#' The special term `pairwise` indicate that the model should be fitted individually for
#' every tested level in comparison to the reference level.
#'
#' @param x the variable for which pairwise result is expected
#'
#' @details Let's `ARM` being a factor with level A, B, C; let's be B the reference level,
#'   a model calling the formula including `pairwise(ARM)` will result in two models:
#'   * A model including only levels A and B, and effect of A estimated in reference to B.
#'   * A model including only levels C and B, the effect of C estimated in reference to B.
#'
#' @export
pairwise <- function(x) {
  structure(x, varname = deparse(substitute(x)))
}

#' Univariate Formula Special Term
#'
#' @description `r lifecycle::badge("stable")`
#'
#' The special term `univariate` indicate that the model should be fitted individually for
#' every variable included in univariate.
#'
#' @param x A vector of variable name separated by comas.
#'
#' @details
#' If provided alongside with pairwise specification, the model
#' `y ~ ARM + univariate(SEX, AGE, RACE)` lead to the study and comparison of the models
#' + `y ~ ARM`
#' + `y ~ ARM + SEX`
#' + `y ~ ARM + AGE`
#' + `y ~ ARM + RACE`
#'
#' @export
univariate <- function(x) {
  structure(x, varname = deparse(substitute(x)))
}

# Get the right-hand-term of a formula
rht <- function(x) {
  checkmate::assert_formula(x)
  y <- as.character(rev(x)[[1]])
  return(y)
}

#' Hazard Ratio Estimation in Interactions
#'
#' This function estimates the hazard ratios between arms when an interaction variable is given with
#' specific values.
#'
#' @param variable,given Names of two variable in interaction. We seek the estimation of the levels of `variable`
#'   given the levels of `given`.
#' @param lvl_var,lvl_given corresponding levels has given by `levels`.
#' @param mmat A name numeric filled with 0 used as template to obtain the design matrix.
#' @param coef Numeric of estimated coefficients.
#' @param vcov Variance-covariance matrix of underlying model.
#' @param conf_level Single numeric for the confidence level of estimate intervals.
#'
#' @details Given the cox regression investigating the effect of Arm (A, B, C; reference A)
#'   and Sex (F, M; reference Female). The model is abbreviated: y ~ Arm + Sex + Arm x Sex.
#'   The cox regression estimates the coefficients along with a variance-covariance matrix for:
#'
#'   - b1 (arm b), b2 (arm c)
#'   - b3 (sex m)
#'   - b4 (arm b: sex m), b5 (arm c: sex m)
#'
#'   Given that I want an estimation of the Hazard Ratio for arm C/sex M, the estimation
#'   will be given in reference to arm A/Sex M by exp(b2 + b3 + b5)/ exp(b3) = exp(b2 + b5),
#'   therefore the interaction coefficient is given by b2 + b5 while the standard error is obtained
#'   as $1.96 * sqrt(Var b2 + Var b5 + 2 * covariance (b2,b5))$ for a confidence level of 0.95.
#'
#' @return A list of matrix (one per level of variable) with rows corresponding to the combinations of
#' `variable` and `given`, with columns:
#' \describe{
#'   \item{coef_hat}{Estimation of the coefficient.}
#'   \item{coef_se}{Standard error of the estimation.}
#'   \item{hr}{Hazard ratio.}
#'   \item{lcl, ucl}{Lower/upper confidence limit of the hazard ratio.}
#' }
#' @seealso [s_cox_multivariate()].
#'
#' @examples
#' library(dplyr)
#' library(survival)
#'
#' ADSL <- tern_ex_adsl %>%
#'   filter(SEX %in% c("F", "M"))
#'
#' adtte <- tern_ex_adtte %>% filter(PARAMCD == "PFS")
#' adtte$ARMCD <- droplevels(adtte$ARMCD)
#' adtte$SEX <- droplevels(adtte$SEX)
#'
#' mod <- coxph(
#'   formula = Surv(time = AVAL, event = 1 - CNSR) ~ (SEX + ARMCD)^2,
#'   data = adtte
#' )
#'
#' mmat <- stats::model.matrix(mod)[1, ]
#' mmat[!mmat == 0] <- 0
#'
#' # Internal function - estimate_coef
#' \dontrun{
#' estimate_coef(
#'   variable = "ARMCD", given = "SEX", lvl_var = "ARM A", lvl_given = "M",
#'   coef = stats::coef(mod), mmat = mmat, vcov = stats::vcov(mod), conf_level = .95
#' )
#' }
#'
#' @keywords internal
estimate_coef <- function(variable, given,
                          lvl_var, lvl_given,
                          coef,
                          mmat,
                          vcov,
                          conf_level = 0.95) {
  var_lvl <- paste0(variable, lvl_var[-1]) # [-1]: reference level
  giv_lvl <- paste0(given, lvl_given)

  design_mat <- expand.grid(variable = var_lvl, given = giv_lvl)
  design_mat <- design_mat[order(design_mat$variable, design_mat$given), ]
  design_mat <- within(
    data = design_mat,
    expr = {
      inter <- paste0(variable, ":", given) # nolint
      rev_inter <- paste0(given, ":", variable) # nolint
    }
  )

  split_by_variable <- design_mat$variable
  interaction_names <- paste(design_mat$variable, design_mat$given, sep = "/")

  design_mat <- apply(
    X = design_mat, MARGIN = 1, FUN = function(x) {
      mmat[names(mmat) %in% x[-which(names(x) == "given")]] <- 1
      return(mmat)
    }
  )
  colnames(design_mat) <- interaction_names

  betas <- as.matrix(coef)

  coef_hat <- t(design_mat) %*% betas
  dimnames(coef_hat)[2] <- "coef"

  coef_se <- apply(design_mat, 2, function(x) {
    vcov_el <- as.logical(x)
    y <- vcov[vcov_el, vcov_el]
    y <- sum(y)
    y <- sqrt(y)
    return(y)
  })

  q_norm <- stats::qnorm((1 + conf_level) / 2)
  y <- cbind(coef_hat, `se(coef)` = coef_se)

  y <- apply(y, 1, function(x) {
    x["hr"] <- exp(x["coef"])
    x["lcl"] <- exp(x["coef"] - q_norm * x["se(coef)"])
    x["ucl"] <- exp(x["coef"] + q_norm * x["se(coef)"])

    return(x)
  })

  y <- t(y)
  y <- by(y, split_by_variable, identity)
  y <- lapply(y, as.matrix)

  attr(y, "details") <- paste0(
    "Estimations of ", variable,
    " hazard ratio given the level of ", given, " compared to ",
    variable, " level ", lvl_var[1], "."
  )
  return(y)
}

#' `tryCatch` around `car::Anova`
#'
#' Captures warnings when executing [car::Anova].
#'
#' @inheritParams car::Anova
#'
#' @return A list with item `aov` for the result of the model and
#'   `error_text` for the captured warnings.
#'
#' @examples
#' # `car::Anova` on cox regression model including strata and expected
#' # a likelihood ratio test triggers a warning as only Wald method is
#' # accepted.
#'
#' library(survival)
#'
#' mod <- coxph(
#'   formula = Surv(time = futime, event = fustat) ~ factor(rx) + strata(ecog.ps),
#'   data = ovarian
#' )
#'
#' # Internal function - try_car_anova
#' \dontrun{
#' with_wald <- try_car_anova(mod = mod, test.statistic = "Wald")
#' with_lr <- try_car_anova(mod = mod, test.statistic = "LR")
#' }
#'
#' @keywords internal
try_car_anova <- function(mod,
                          test.statistic) { # nolint
  y <- tryCatch(
    withCallingHandlers(
      expr = {
        warn_text <- c()
        list(
          aov = car::Anova(
            mod,
            test.statistic = test.statistic,
            type = "III"
          ),
          warn_text = warn_text
        )
      },
      warning = function(w) {
        # If a warning is detected it is handled as "w".
        warn_text <<- trimws(paste0("Warning in `try_car_anova`: ", w))

        # A warning is sometimes expected, then, we want to restart
        # the execution while ignoring the warning.
        invokeRestart("muffleWarning")
      }
    ),
    finally = {
    }
  )

  return(y)
}

#' Fit the Cox Regression Model and Anova
#'
#' The functions allows to derive from the [survival::coxph()] results
#' the effect p.values using [car::Anova()]. This last package introduces
#' more flexibility to get the effect p.values.
#'
#' @inheritParams t_coxreg
#' @noRd
#'
#' @return A list with items `mod` (results of [survival::coxph()]),
#' `msum` (result of `summary`) and `aov` (result of [car::Anova]).
fit_n_aov <- function(formula,
                      data = data,
                      conf_level = conf_level,
                      pval_method = c("wald", "likelihood"),
                      ...) {
  pval_method <- match.arg(pval_method)

  environment(formula) <- environment()
  suppressWarnings({
    # We expect some warnings due to coxph which fails strict programming.
    mod <- survival::coxph(formula, data = data, ...)
    msum <- summary(mod, conf.int = conf_level)
  })

  aov <- try_car_anova(
    mod,
    test.statistic = switch(pval_method,
      "wald" = "Wald",
      "likelihood" = "LR"
    )
  )

  warn_attr <- aov$warn_text
  if (!is.null(aov$warn_text)) message(warn_attr)

  aov <- aov$aov
  y <- list(mod = mod, msum = msum, aov = aov)
  attr(y, "message") <- warn_attr

  return(y)
}

# argument_checks
check_formula <- function(formula) {
  if (!(inherits(formula, "formula"))) {
    stop("Check `formula`. A formula should resemble `Surv(time = AVAL, event = 1 - CNSR) ~ study_arm(ARMCD)`.")
  }

  invisible()
}

check_covariate_formulas <- function(covariates) {
  if (!all(vapply(X = covariates, FUN = inherits, what = "formula", FUN.VALUE = TRUE)) || is.null(covariates)) {
    stop("Check `covariates`, it should be a list of right-hand-term formulas, e.g. list(Age = ~AGE).")
  }

  invisible()
}

name_covariate_names <- function(covariates) {
  miss_names <- names(covariates) == ""
  no_names <- is.null(names(covariates))
  if (any(miss_names)) names(covariates)[miss_names] <- vapply(covariates[miss_names], FUN = rht, FUN.VALUE = "name")
  if (no_names) names(covariates) <- vapply(covariates, FUN = rht, FUN.VALUE = "name")
  return(covariates)
}

check_increments <- function(increments, covariates) {
  if (!is.null(increments)) {
    covariates <- vapply(covariates, FUN = rht, FUN.VALUE = "name")
    lapply(
      X = names(increments), FUN = function(x) {
        if (!x %in% covariates) {
          warning(
            paste(
              "Check `increments`, the `increment` for ", x,
              "doesn't match any names in investigated covariate(s)."
            )
          )
        }
      }
    )
  }

  invisible()
}

#' Multivariate Cox Model - Summarized Results
#'
#' Analyses based on multivariate Cox model are usually not performed for the Controlled Substance Reporting or
#' regulatory documents but serve exploratory purposes only (e.g., for publication). In practice, the model usually
#' includes only the main effects (without interaction terms). It produces the hazard ratio estimates for each of the
#' covariates included in the model.
#' The analysis follows the same principles (e.g., stratified vs. unstratified analysis and tie handling) as the
#' usual Cox model analysis. Since there is usually no pre-specified hypothesis testing for such analysis,
#' the p.values need to be interpreted with caution. (**Statistical Analysis of Clinical Trials Data with R**,
#' `NEST's bookdown`)
#'
#' @param formula (`formula`)\cr A formula corresponding to the investigated [survival::Surv()] survival model
#'   including covariates.
#' @param data (`data.frame`)\cr A data frame which includes the variable in formula and covariates.
#' @param conf_level (`proportion`)\cr The confidence level for the hazard ratio interval estimations. Default is 0.95.
#' @param pval_method (`character`)\cr The method used for the estimation of p-values, should be one of
#'   "wald" (default) or "likelihood".
#' @param ... Optional parameters passed to [survival::coxph()]. Can include `ties`, a character string specifying the
#'   method for tie handling, one of `exact` (default), `efron`, `breslow`.
#'
#' @details The output is limited to single effect terms. Work in ongoing for estimation of interaction terms
#'   but is out of scope as defined by the  Global Data Standards Repository
#'   (**`GDS_Standard_TLG_Specs_Tables_2.doc`**).
#' @seealso [estimate_coef()].
#'
#' @examples
#' library(dplyr)
#'
#' adtte <- tern_ex_adtte
#' adtte_f <- subset(adtte, PARAMCD == "OS") # _f: filtered
#' adtte_f <- filter(
#'   adtte_f,
#'   PARAMCD == "OS" &
#'     SEX %in% c("F", "M") &
#'     RACE %in% c("ASIAN", "BLACK OR AFRICAN AMERICAN", "WHITE")
#' )
#' adtte_f$SEX <- droplevels(adtte_f$SEX)
#' adtte_f$RACE <- droplevels(adtte_f$RACE)
#'
#' # Internal function - s_cox_multivariate
#' \dontrun{
#' s_cox_multivariate(
#'   formula = Surv(time = AVAL, event = 1 - CNSR) ~ (ARMCD + RACE + AGE)^2, data = adtte_f
#' )
#' }
#'
#' @keywords internal
s_cox_multivariate <- function(formula, data,
                               conf_level = 0.95,
                               pval_method = c("wald", "likelihood"),
                               ...) {
  tf <- stats::terms(formula, specials = c("strata"))
  covariates <- rownames(attr(tf, "factors"))[-c(1, unlist(attr(tf, "specials")))]
  lapply(
    X = covariates,
    FUN = function(x) {
      if (is.character(data[[x]])) {
        data[[x]] <<- as.factor(data[[x]])
      }
      invisible()
    }
  )
  pval_method <- match.arg(pval_method)

  # Results directly exported from environment(fit_n_aov) to environment(s_function_draft)
  y <- fit_n_aov(
    formula = formula,
    data = data,
    conf_level = conf_level,
    pval_method = pval_method,
    ...
  )
  mod <- y$mod
  aov <- y$aov
  msum <- y$msum
  list2env(as.list(y), environment())

  all_term_labs <- attr(mod$terms, "term.labels")
  term_labs <- all_term_labs[which(attr(mod$terms, "order") == 1)]
  names(term_labs) <- term_labs

  coef_inter <- NULL
  if (any(attr(mod$terms, "order") > 1)) {
    for_inter <- all_term_labs[attr(mod$terms, "order") > 1]
    names(for_inter) <- for_inter
    mmat <- stats::model.matrix(mod)[1, ]
    mmat[!mmat == 0] <- 0
    mcoef <- stats::coef(mod)
    mvcov <- stats::vcov(mod)

    estimate_coef_local <- function(variable, given) {
      estimate_coef(
        variable, given,
        coef = mcoef, mmat = mmat, vcov = mvcov, conf_level = conf_level,
        lvl_var = levels(data[[variable]]), lvl_given = levels(data[[given]])
      )
    }

    coef_inter <- lapply(
      for_inter, function(x) {
        y <- attr(mod$terms, "factor")[, x]
        y <- names(y[y > 0])
        Map(estimate_coef_local, variable = y, given = rev(y))
      }
    )
  }

  list(mod = mod, msum = msum, aov = aov, coef_inter = coef_inter)
}

#' Incidence Rate
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Estimate the event rate adjusted for person-years at risk, otherwise known
#' as incidence rate. Primary analysis variable is the person-years at risk.
#'
#' @inheritParams argument_convention
#' @param control (`list`)\cr parameters for estimation details, specified by using
#'   the helper function [control_incidence_rate()]. Possible parameter options are:
#'   * `conf_level` (`proportion`)\cr confidence level for the estimated incidence rate.
#'   * `conf_type` (`string`)\cr `normal` (default), `normal_log`, `exact`, or `byar`
#'     for confidence interval type.
#'   * `time_unit_input` (`string`)\cr `day`, `week`, `month`, or `year` (default)
#'     indicating time unit for data input.
#'   * `time_unit_output` (`numeric`)\cr time unit for desired output (in person-years).
#' @param person_years (`numeric`)\cr total person-years at risk.
#' @param alpha (`numeric`)\cr two-sided alpha-level for confidence interval.
#' @param n_events (`integer`)\cr number of events observed.
#'
#' @seealso [control_incidence_rate()] and helper functions [h_incidence_rate].
#'
#' @name incidence_rate
NULL

#' @describeIn incidence_rate Statistics function which estimates the incidence rate and the
#'   associated confidence interval.
#'
#' @return The statistics are:
#' \describe{
#'   \item{person_years}{total person-years at risk}
#'   \item{n_events}{total number of events observed}
#'   \item{rate}{estimated incidence rate}
#'   \item{rate_ci}{confidence interval for the incidence rate}
#' }
#'
#' @examples
#' library(dplyr)
#'
#' df <- data.frame(
#'   USUBJID = as.character(seq(6)),
#'   CNSR = c(0, 1, 1, 0, 0, 0),
#'   AVAL = c(10.1, 20.4, 15.3, 20.8, 18.7, 23.4),
#'   ARM = factor(c("A", "A", "A", "B", "B", "B"))
#' ) %>%
#'   mutate(is_event = CNSR == 0) %>%
#'   mutate(n_events = as.integer(is_event))
#'
#' # Internal function - s_incidence_rate
#' \dontrun{
#' s_incidence_rate(
#'   df,
#'   .var = "AVAL",
#'   n_events = "n_events",
#'   control = control_incidence_rate(
#'     time_unit_input = "month",
#'     time_unit_output = 100
#'   )
#' )
#' }
#'
#' @keywords internal
s_incidence_rate <- function(df,
                             .var,
                             n_events,
                             is_event,
                             control = control_incidence_rate()) {
  if (!missing(is_event)) {
    warning("argument is_event will be deprecated. Please use n_events.")

    if (missing(n_events)) {
      assert_df_with_variables(df, list(tte = .var, is_event = is_event))
      checkmate::assert_string(.var)
      checkmate::assert_logical(df[[is_event]], any.missing = FALSE)
      checkmate::assert_numeric(df[[.var]], any.missing = FALSE)
      n_events <- is_event
    }
  } else {
    assert_df_with_variables(df, list(tte = .var, n_events = n_events))
    checkmate::assert_string(.var)
    checkmate::assert_numeric(df[[.var]], any.missing = FALSE)
    checkmate::assert_integer(df[[n_events]], any.missing = FALSE)
  }

  time_unit_input <- control$time_unit_input
  time_unit_output <- control$time_unit_output
  conf_level <- control$conf_level
  person_years <- sum(df[[.var]], na.rm = TRUE) * (
    1 * (time_unit_input == "year") +
      1 / 12 * (time_unit_input == "month") +
      1 / 52.14 * (time_unit_input == "week") +
      1 / 365.24 * (time_unit_input == "day")
  )
  n_events <- sum(df[[n_events]], na.rm = TRUE)

  result <- h_incidence_rate(
    person_years,
    n_events,
    control
  )
  list(
    person_years = formatters::with_label(person_years, "Total patient-years at risk"),
    n_events = formatters::with_label(n_events, "Number of adverse events observed"),
    rate = formatters::with_label(result$rate, paste("AE rate per", time_unit_output, "patient-years")),
    rate_ci = formatters::with_label(result$rate_ci, f_conf_level(conf_level))
  )
}


#' @describeIn incidence_rate Formatted Analysis function which can be further customized by calling
#'   [rtables::make_afun()] on it. It is used as `afun` in [rtables::analyze()].
#'
#' @examples
#' # Internal function - a_incidence_rate
#' \dontrun{
#' a_incidence_rate(
#'   df,
#'   .var = "AVAL",
#'   n_events = "n_events",
#'   control = control_incidence_rate(time_unit_input = "month", time_unit_output = 100)
#' )
#' }
#'
#' @keywords internal
a_incidence_rate <- make_afun(
  s_incidence_rate,
  .formats = c(
    "person_years" = "xx.x",
    "n_events" = "xx",
    "rate" = "xx.xx",
    "rate_ci" = "(xx.xx, xx.xx)"
  )
)

#' @describeIn incidence_rate Layout creating function which adds analyze rows using the statistics
#' function `s_incidence_rate` and desired format.
#'
#' @examples
#' basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   add_colcounts() %>%
#'   estimate_incidence_rate(
#'     vars = "AVAL",
#'     n_events = "n_events",
#'     control = control_incidence_rate(
#'       time_unit_input = "month",
#'       time_unit_output = 100
#'     )
#'   ) %>%
#'   build_table(df)
#'
#' @export
estimate_incidence_rate <- function(lyt,
                                    vars,
                                    ...,
                                    show_labels = "hidden",
                                    table_names = vars,
                                    .stats = NULL,
                                    .formats = NULL,
                                    .labels = NULL,
                                    .indent_mods = NULL) {
  afun <- make_afun(
    a_incidence_rate,
    .stats = .stats,
    .formats = .formats,
    .labels = .labels,
    .indent_mods = .indent_mods
  )

  analyze(
    lyt,
    vars,
    show_labels = show_labels,
    table_names = table_names,
    afun = afun,
    extra_args = list(...)
  )
}

#' Helper Functions for Incidence Rate
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @param control (`list`)\cr parameters for estimation details, specified by using
#'   the helper function [control_incidence_rate()]. Possible parameter options are:
#'   * `conf_level`: (`proportion`)\cr confidence level for the estimated incidence rate.
#'   * `conf_type`: (`string`)\cr `normal` (default), `normal_log`, `exact`, or `byar`
#'     for confidence interval type.
#'   * `time_unit_input`: (`string`)\cr `day`, `week`, `month`, or `year` (default)
#'     indicating time unit for data input.
#'   * `time_unit_output`: (`numeric`)\cr time unit for desired output (in person-years).
#'
#' @param person_years (`numeric`)\cr total person-years at risk.
#' @param alpha (`numeric`)\cr two-sided alpha-level for confidence interval.
#' @param n_events (`integer`)\cr number of events observed.
#'
#' @seealso [incidence_rate]
#'
#' @name h_incidence_rate
NULL

#' @describeIn h_incidence_rate Helper function to estimate the incidence rate and
#'   associated confidence interval based on the normal approximation for the
#'   incidence rate. Unit is one person-year.
#'
#' @examples
#' h_incidence_rate_normal(200, 2)
#'
#' @export
h_incidence_rate_normal <- function(person_years,
                                    n_events,
                                    alpha = 0.05) {
  checkmate::assert_number(person_years)
  checkmate::assert_number(n_events)
  assert_proportion_value(alpha)

  est <- n_events / person_years
  se <- sqrt(est / person_years)
  ci <- est + c(-1, 1) * stats::qnorm(1 - alpha / 2) * se

  list(rate = est, rate_ci = ci)
}

#' @describeIn h_incidence_rate Helper function to estimate the incidence rate and
#'   associated confidence interval based on the normal approximation for the
#'   logarithm of the incidence rate. Unit is one person-year.
#'
#' @examples
#' h_incidence_rate_normal_log(200, 2)
#'
#' @export
h_incidence_rate_normal_log <- function(person_years,
                                        n_events,
                                        alpha = 0.05) {
  checkmate::assert_number(person_years)
  checkmate::assert_number(n_events)
  assert_proportion_value(alpha)

  rate_est <- n_events / person_years
  rate_se <- sqrt(rate_est / person_years)
  lrate_est <- log(rate_est)
  lrate_se <- rate_se / rate_est
  ci <- exp(lrate_est + c(-1, 1) * stats::qnorm(1 - alpha / 2) * lrate_se)

  list(rate = rate_est, rate_ci = ci)
}

#' @describeIn h_incidence_rate Helper function to estimate the incidence rate and
#'   associated exact confidence interval. Unit is one person-year.
#'
#' @examples
#' h_incidence_rate_exact(200, 2)
#'
#' @export
h_incidence_rate_exact <- function(person_years,
                                   n_events,
                                   alpha = 0.05) {
  checkmate::assert_number(person_years)
  checkmate::assert_number(n_events)
  assert_proportion_value(alpha)

  est <- n_events / person_years
  lcl <- stats::qchisq(p = (alpha) / 2, df = 2 * n_events) / (2 * person_years)
  ucl <- stats::qchisq(p = 1 - (alpha) / 2, df = 2 * n_events + 2) / (2 * person_years)

  list(rate = est, rate_ci = c(lcl, ucl))
}

#' @describeIn h_incidence_rate Helper function to estimate the incidence rate and
#'   associated Byar's confidence interval. Unit is one person-year.
#'
#' @examples
#' h_incidence_rate_byar(200, 2)
#'
#' @export
h_incidence_rate_byar <- function(person_years,
                                  n_events,
                                  alpha = 0.05) {
  checkmate::assert_number(person_years)
  checkmate::assert_number(n_events)
  assert_proportion_value(alpha)

  est <- n_events / person_years
  seg_1 <- n_events + 0.5
  seg_2 <- 1 - 1 / (9 * (n_events + 0.5))
  seg_3 <- stats::qnorm(1 - alpha / 2) * sqrt(1 / (n_events + 0.5)) / 3
  lcl <- seg_1 * ((seg_2 - seg_3)^3) / person_years
  ucl <- seg_1 * ((seg_2 + seg_3) ^ 3) / person_years # styler: off

  list(rate = est, rate_ci = c(lcl, ucl))
}

#' @describeIn h_incidence_rate Helper function to estimate the incidence rate and
#'   associated confidence interval.
#'
#' @examples
#' # Internal function - h_incidence_rate
#' \dontrun{
#' h_incidence_rate(200, 2)
#'
#' h_incidence_rate(
#'   200,
#'   2,
#'   control_incidence_rate(
#'     conf_level = 0.9,
#'     conf_type = "normal_log",
#'     time_unit_output = 100
#'   )
#' )
#' }
#'
#' @keywords internal
h_incidence_rate <- function(person_years,
                             n_events,
                             control = control_incidence_rate()) {
  alpha <- 1 - control$conf_level
  est <- switch(control$conf_type,
    normal = h_incidence_rate_normal(person_years, n_events, alpha),
    normal_log = h_incidence_rate_normal_log(person_years, n_events, alpha),
    exact = h_incidence_rate_exact(person_years, n_events, alpha),
    byar = h_incidence_rate_byar(person_years, n_events, alpha)
  )

  time_unit_output <- control$time_unit_output
  list(
    rate = est$rate * time_unit_output,
    rate_ci = est$rate_ci * time_unit_output
  )
}

#' Re-implemented \code{\link[base:range]{range.default}} default S3 method for numerical objects only.
#' It returns \code{c(NA, NA)} instead of \code{c(-Inf, Inf)} for zero-length data
#' without any warnings.
#'
#' @param x numeric S3 class, a sequence of numbers for which the range is computed.
#' @param na.rm (`logical`)\cr indicating if NA should be omitted.
#' @param finite (`logical`)\cr indicating if non-finite elements should be removed.
#'
#' @return 2-elements vector of class numeric.
#'
#' @examples
#' # Internal function - range_noinf
#' \dontrun{
#' range_noinf(1:5)
#' range_noinf(c(1:5, NA, NA), na.rm = TRUE)
#' range_noinf(numeric(), na.rm = TRUE)
#' range_noinf(c(1:5, NA, NA, Inf), na.rm = TRUE, finite = TRUE)
#' range_noinf(Inf)
#' range_noinf(Inf, na.rm = TRUE, finite = TRUE)
#' range_noinf(c(Inf, NA), na.rm = FALSE, finite = TRUE)
#' range_noinf(c(1, Inf, NA), na.rm = FALSE, finite = TRUE)
#' }
#'
#' @keywords internal
range_noinf <- function(x, na.rm = FALSE, finite = FALSE) { # nolint

  checkmate::assert_numeric(x)

  if (finite) {
    x <- x[is.finite(x)] # removes NAs too
  } else if (na.rm) {
    x <- x[!is.na(x)]
  }

  if (length(x) == 0) {
    rval <- c(NA, NA)
    mode(rval) <- typeof(x)
  } else {
    rval <- c(min(x, na.rm = FALSE), max(x, na.rm = FALSE))
  }

  return(rval)
}

#' Utility function to create label for confidence interval
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @inheritParams argument_convention
#' @return a `string`
#'
#' @export
f_conf_level <- function(conf_level) {
  assert_proportion_value(conf_level)
  paste0(conf_level * 100, "% CI")
}

#' Utility function to create label for p-value
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @param test_mean (`number`)\cr mean value to test under the null hypothesis.
#' @return a `string`
#'
#' @export
f_pval <- function(test_mean) {
  checkmate::assert_numeric(test_mean, len = 1)
  paste0("p-value (H0: mean = ", test_mean, ")")
}

#' Utility function to return a named list of covariate names.
#'
#' @param covariates (`character`)\cr a vector that can contain single variable names (such as
#'   `"X1"`), and/or interaction terms indicated by `"X1 * X2"`.
#' @return a named `list` of character vector.
#'
#' @keywords internal
get_covariates <- function(covariates) {
  checkmate::assert_character(covariates)
  cov_vars <- unique(trimws(unlist(strsplit(covariates, "\\*"))))
  stats::setNames(as.list(cov_vars), cov_vars)
}

#' Replicate Entries of a Vector if Required
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Replicate entries of a vector if required. Note that this will fail if `x`
#' is not of length `n` or is not a scalar.
#'
#' @inheritParams argument_convention
#' @param n (`count`)\cr how many entries we need.
#'
#' @return Just input `x` if it has the required length already or is `NULL`,
#'   otherwise if it is scalar the replicated version of it with `n` entries.
#'
#' @export
to_n <- function(x, n) {
  if (is.null(x)) {
    NULL
  } else if (length(x) == 1) {
    rep(x, n)
  } else if (length(x) == n) {
    x
  } else {
    stop("dimension mismatch")
  }
}

#' Check Element Dimension
#'
#' @description
#'
#' Checks if the elements in `...` have the same dimension.
#'
#' @param ... data.frames or vectors
#' @param omit_null are \code{NULL} elements in \code{...} to be omitted from the check?
#'
#' @keywords internal
check_same_n <- function(..., omit_null = TRUE) {
  dots <- list(...)

  n_list <- Map(
    function(x, name) {
      if (is.null(x)) {
        if (omit_null) {
          NA_integer_
        } else {
          stop("arg", name, "is not supposed to be NULL")
        }
      } else if (is.data.frame(x)) {
        nrow(x)
      } else if (is.atomic(x)) {
        length(x)
      } else {
        stop("data structure for ", name, "is currently not supported")
      }
    },
    dots, names(dots)
  )

  n <- stats::na.omit(unlist(n_list))

  if (length(unique(n)) > 1) {
    sel <- which(n != n[1])
    stop("dimension mismatch:", paste(names(n)[sel], collapse = ", "), " do not have N=", n[1])
  }

  TRUE
}

#' Make Names Without Dots
#'
#' @param nams (`character`)\cr vector of original names.
#'
#' @return Character vector of proper names, which does not use dots in contrast to
#'   [base::make.names()].
#'
#' @examples
#' # Internal function - make_names
#' \dontrun{
#' make_names(c("foo Bar", "1 2 3 bla"))
#' }
#'
#' @keywords internal
make_names <- function(nams) {
  orig <- make.names(nams)
  gsub(".", "", x = orig, fixed = TRUE)
}

#' Conversion of Months to Days
#'
#' @description
#'
#' Conversion of Months to Days. This is an approximative calculation because it
#' considers each month as having an average of 30.4375 days.
#'
#' @param x (`numeric`)\cr time in months.
#'
#' @return A `numeric` vector with the time in days.
#'
#' @examples
#' x <- c(13.25, 8.15, 1, 2.834)
#' month2day(x)
#'
#' @export
month2day <- function(x) {
  checkmate::assert_numeric(x)
  x * 30.4375
}

#' Conversion of Days to Months
#'
#' @param x (`numeric`)\cr time in days.
#'
#' @return A `numeric` vector with the time in months.
#'
#' @examples
#' x <- c(403, 248, 30, 86)
#' day2month(x)
#'
#' @export
day2month <- function(x) {
  checkmate::assert_numeric(x)
  x / 30.4375
}

#' Return an empty numeric if all elements are `NA`.
#'
#' @param x (`numeric`)\cr vector.
#'
#' @return An empty `numeric`.
#'
#' @examples
#' x <- c(NA, NA, NA)
#' # Internal function - empty_vector_if_na
#' \dontrun{
#' empty_vector_if_na(x)
#' }
#'
#' @keywords internal
empty_vector_if_na <- function(x) {
  if (all(is.na(x))) {
    numeric()
  } else {
    x
  }
}

#' Combine Two Vectors Element Wise
#'
#' @param x (`vector`)\cr first vector to combine.
#' @param y (`vector`)\cr second vector to combine.
#'
#' @return A `list` where each element combines corresponding elements of `x` and `y`.
#'
#' @examples
#' combine_vectors(1:3, 4:6)
#'
#' @export
combine_vectors <- function(x, y) {
  checkmate::assert_vector(x)
  checkmate::assert_vector(y, len = length(x))

  result <- lapply(as.data.frame(rbind(x, y)), `c`)
  names(result) <- NULL
  result
}

#' Extract Elements by Name
#'
#' @description
#'
#' This utility function extracts elements from a vector `x` by `names`.
#' Differences to the standard [base::`[`()] function are:
#'
#' - If `x` is `NULL`, then still always `NULL` is returned (same as in base function).
#' - If `x` is not `NULL`, then the intersection of its names is made with `names` and those
#'   elements are returned. That is, `names` which don't appear in `x` are not returned as `NA`s.
#'
#' @param x (named `vector`)\cr where to extract named elements from.
#' @param names (`character`)\cr vector of names to extract.
#'
#' @return Either `NULL` or the extracted elements from `x`.
#'
#' @keywords internal
extract_by_name <- function(x, names) {
  if (is.null(x)) {
    return(NULL)
  }
  checkmate::assert_named(x)
  checkmate::assert_character(names)
  which_extract <- intersect(names(x), names)
  if (length(which_extract) > 0) {
    x[which_extract]
  } else {
    NULL
  }
}

#' Labels for Adverse Event Baskets
#'
#' @description `r lifecycle::badge("stable")`
#' @param aesi (`character`)\cr with standardized MedDRA query name (e.g. `SMQzzNAM`) or customized query
#'   name (e.g. `CQzzNAM`).
#' @param scope (`character`)\cr with scope of query (e.g. `SMQzzSC`).
#'
#' @return A `string` with the standard label for the AE basket.
#'
#' @export
#'
#' @examples
#' adae <- tern_ex_adae
#'
#' # Standardized query label includes scope.
#' aesi_label(adae$SMQ01NAM, scope = adae$SMQ01SC)
#'
#' # Customized query label.
#' aesi_label(adae$CQ01NAM)
aesi_label <- function(aesi, scope = NULL) {
  checkmate::assert_character(aesi)
  checkmate::assert_character(scope, null.ok = TRUE)
  aesi_label <- obj_label(aesi)
  aesi <- sas_na(aesi)
  aesi <- unique(aesi)[!is.na(unique(aesi))]

  lbl <- if (length(aesi) == 1 && !is.null(scope)) {
    scope <- sas_na(scope)
    scope <- unique(scope)[!is.na(unique(scope))]
    checkmate::assert_string(scope)
    paste0(aesi, " (", scope, ")")
  } else if (length(aesi) == 1 && is.null(scope)) {
    aesi
  } else {
    aesi_label
  }

  lbl
}

#' Indicate Study Arm Variable in Formula
#'
#' @description
#'
#' We use `study_arm` to indicate the study arm variable in `tern` formulas.
#'
#' @param x arm information
#'
#' @keywords internal
#'
study_arm <- function(x) {
  structure(x, varname = deparse(substitute(x)))
}

#' Smooth Function with Optional Grouping
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This produces \code{loess} smoothed estimates of `y` with Student confidence intervals.
#'
#' @param df (`data.frame`)\cr data set containing all analysis variables.
#' @param x (`character`)\cr value with x column name.
#' @param y (`character`)\cr value with y column name.
#' @param groups (`character`)\cr vector with optional grouping variables names.
#' @param level (`numeric`)\cr level of confidence interval to use (0.95 by default).
#' @return A `data.frame` with original `x`, smoothed `y`, `ylow`, `yhigh` and
#' optional `groups` variables formatted to factor type.
#' @export
#'
get_smooths <- function(df, x, y, groups = NULL, level = 0.95) {
  checkmate::assert_data_frame(df)
  df_cols <- colnames(df)
  checkmate::assert_string(x)
  checkmate::assert_subset(x, df_cols)
  checkmate::assert_numeric(df[[x]])
  checkmate::assert_string(y)
  checkmate::assert_subset(y, df_cols)
  checkmate::assert_numeric(df[[y]])

  if (!is.null(groups)) {
    checkmate::assert_character(groups)
    checkmate::assert_subset(groups, df_cols)
  }

  smooths <- function(x, y) {
    stats::predict(stats::loess(y ~ x), se = TRUE)
  }

  if (!is.null(groups)) {
    cc <- stats::complete.cases(df[c(x, y, groups)])
    df_c <- df[cc, c(x, y, groups)]
    df_c_ordered <- df_c[do.call("order", as.list(df_c[, groups, drop = FALSE])), , drop = FALSE]
    df_c_g <- data.frame(Map(as.factor, df_c_ordered[groups]))

    df_smooth_raw <-
      by(df_c_ordered, df_c_g, function(d) {
        plx <- smooths(d[[x]], d[[y]])
        data.frame(
          x = d[[x]],
          y = plx$fit,
          ylow = plx$fit - stats::qt(level, plx$df) * plx$se,
          yhigh = plx$fit + stats::qt(level, plx$df) * plx$se
        )
      })

    df_smooth <- do.call(rbind, df_smooth_raw)
    df_smooth[groups] <- df_c_g

    df_smooth
  } else {
    cc <- stats::complete.cases(df[c(x, y)])
    df_c <- df[cc, ]
    plx <- smooths(df_c[[x]], df_c[[y]])

    df_smooth <- data.frame(
      x = df_c[[x]],
      y = plx$fit,
      ylow = plx$fit - stats::qt(level, plx$df) * plx$se,
      yhigh = plx$fit + stats::qt(level, plx$df) * plx$se
    )

    df_smooth
  }
}

#' Number of Available (Non-Missing Entries) in a Vector
#'
#' @description
#'
#' Small utility function for better readability.
#'
#' @param x (`any`)\cr vector in which to count non-missing values.
#'
#' @return Number of non-missing values.
#'
#' @examples
#' # Internal function - n_available
#' \dontrun{
#' n_available(c(1, NA, 2))
#' }
#'
#' @keywords internal
n_available <- function(x) {
  sum(!is.na(x))
}

#' Reapply Variable Labels
#'
#' @description This is a helper function that is used in tests.
#'
#' @param x (`vector`)\cr vector of elements that needs new labels.
#' @param varlabels (`character`)\cr vector of labels for `x`.
#' @param ... further parameters to be added to the list.
#'
#' @export
reapply_varlabels <- function(x, varlabels, ...) {
  named_labels <- c(as.list(varlabels), list(...))
  formatters::var_labels(x)[names(named_labels)] <- as.character(named_labels)
  x
}

# Wrapper function of survival::clogit so that when model fitting failed, a more useful message would show
clogit_with_tryCatch <- function(formula, data, ...) { # nolint
  tryCatch(
    survival::clogit(formula = formula, data = data, ...),
    error = function(e) stop("model not built successfully with survival::clogit")
  )
}

#' Count Patients with Marked Laboratory Abnormalities
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Primary analysis variable `.var` indicates whether single, replicated
#' or last marked laboratory abnormality was observed (factor).
#' Additional analysis variables are `id` (character or factor) and `direction` indicating
#' the direction of the abnormality (factor).
#' Denominator is number of patients with at least one valid measurement during
#'   * For `Single, not last` and `Last or replicated`: Numerator is number of patients
#'     with `Single, not last` and `Last or replicated` levels, respectively.
#'   * For `Any`: Numerator is the number of patients with either single or
#'     replicated marked abnormalities.
#'
#' @details Note that `Single, not last` and `Last or replicated` levels are
#' mutually exclusive. If a patient has abnormalities that meet both the `Single, not last`
#' and `Last or replicated` criteria, then the patient will be counted only under the `Last or replicated` category.
#'
#' @inheritParams argument_convention
#' @param category (`list`)\cr with different marked category names for single
#'   and last or replicated.
#'
#' @name abnormal_by_marked
NULL

#' @describeIn abnormal_by_marked Statistics function which returns
#'   the counts and fractions of patients with `Single, not last`, `Last or replicated` and `Any`
#'   marked laboratory abnormalities for a single `abnormal` level.
#'
#' @return [s_count_abnormal_by_marked()] the single statistic `count_fraction`
#'   with `Single, not last`, `Last or replicated` and `Any` results.
#'
#' @examples
#' library(dplyr)
#'
#' df <- data.frame(
#'   USUBJID = as.character(c(rep(1, 5), rep(2, 5), rep(1, 5), rep(2, 5))),
#'   ARMCD = factor(c(rep("ARM A", 5), rep("ARM B", 5), rep("ARM A", 5), rep("ARM B", 5))),
#'   ANRIND = factor(c(
#'     "NORMAL", "HIGH", "HIGH", "HIGH HIGH", "HIGH",
#'     "HIGH", "HIGH", "HIGH HIGH", "NORMAL", "HIGH HIGH", "NORMAL", "LOW", "LOW", "LOW LOW", "LOW",
#'     "LOW", "LOW", "LOW LOW", "NORMAL", "LOW LOW"
#'   )),
#'   ONTRTFL = rep(c("", "Y", "Y", "Y", "Y", "Y", "Y", "Y", "Y", "Y"), 2),
#'   PARAMCD = factor(c(rep("CRP", 10), rep("ALT", 10))),
#'   AVALCAT1 = factor(rep(c("", "", "", "SINGLE", "REPLICATED", "", "", "LAST", "", "SINGLE"), 2)),
#'   stringsAsFactors = FALSE
#' )
#'
#' df <- df %>%
#'   mutate(abn_dir = factor(
#'     case_when(
#'       ANRIND == "LOW LOW" ~ "Low",
#'       ANRIND == "HIGH HIGH" ~ "High",
#'       TRUE ~ ""
#'     ),
#'     levels = c("Low", "High")
#'   ))
#'
#' # Select only post-baseline records.
#' df <- df %>% filter(ONTRTFL == "Y")
#' df_crp <- df %>%
#'   filter(PARAMCD == "CRP") %>%
#'   droplevels()
#' full_parent_df <- list(df_crp, "not_needed")
#' cur_col_subset <- list(rep(TRUE, nrow(df_crp)), "not_needed")
#' spl_context <- data.frame(
#'   split = c("PARAMCD", "GRADE_DIR"),
#'   full_parent_df = I(full_parent_df),
#'   cur_col_subset = I(cur_col_subset)
#' )
#' # Internal function - s_count_abnormal_by_marked
#' \dontrun{
#' s_count_abnormal_by_marked(
#'   df = df_crp %>% filter(abn_dir == "High"),
#'   .spl_context = spl_context,
#'   .var = "AVALCAT1",
#'   variables = list(id = "USUBJID", param = "PARAMCD", direction = "abn_dir")
#' )
#' }
#'
#' @keywords internal
s_count_abnormal_by_marked <- function(df,
                                       .var = "AVALCAT1",
                                       .spl_context,
                                       category = list(single = "SINGLE", last_replicated = c("LAST", "REPLICATED")),
                                       variables = list(id = "USUBJID", param = "PARAM", direction = "abn_dir")) {
  checkmate::assert_string(.var)
  checkmate::assert_list(variables)
  checkmate::assert_list(category)
  checkmate::assert_subset(names(category), c("single", "last_replicated"))
  checkmate::assert_subset(names(variables), c("id", "param", "direction"))
  checkmate::assert_vector(unique(df[[variables$direction]]), max.len = 1)

  assert_df_with_variables(df, c(aval = .var, variables))
  checkmate::assert_multi_class(df[[.var]], classes = c("factor", "character"))
  checkmate::assert_multi_class(df[[variables$id]], classes = c("factor", "character"))


  first_row <- .spl_context[.spl_context$split == variables[["param"]], ] # nolint
  # Patients in the denominator have at least one post-baseline visit.
  subj <- first_row$full_parent_df[[1]][[variables[["id"]]]]
  subj_cur_col <- subj[first_row$cur_col_subset[[1]]]
  # Some subjects may have a record for high and low directions but
  # should be counted only once.
  denom <- length(unique(subj_cur_col))

  if (denom != 0) {
    subjects_last_replicated <- unique(
      df[df[[.var]] %in% category[["last_replicated"]], variables$id, drop = TRUE]
    )
    subjects_single <- unique(
      df[df[[.var]] %in% category[["single"]], variables$id, drop = TRUE]
    )
    # Subjects who have both single and last/replicated abnormalities are counted in only the last/replicated group.
    subjects_single <- setdiff(subjects_single, subjects_last_replicated)
    n_single <- length(subjects_single)
    n_last_replicated <- length(subjects_last_replicated)
    n_any <- n_single + n_last_replicated
    result <- list(count_fraction = list(
      "Single, not last" = c(n_single, n_single / denom),
      "Last or replicated" = c(n_last_replicated, n_last_replicated / denom),
      "Any Abnormality" = c(n_any, n_any / denom)
    ))
  } else {
    result <- list(count_fraction = list(
      "Single, not last" = c(0, 0),
      "Last or replicated" = c(0, 0),
      "Any Abnormality" = c(0, 0)
    ))
  }

  result
}

#' @describeIn abnormal_by_marked Formatted Analysis function which can be further customized by calling
#'   [rtables::make_afun()] on it. It is used as `afun` in [rtables::analyze()].
#'
#' @return [a_count_abnormal_by_marked()] returns the corresponding list with formatted [rtables::CellValue()].
#'
#' @examples
#' # Internal function - a_count_abnormal_by_marked
#' \dontrun{
#' # Use the Formatted Analysis function for `analyze()`. We need to ungroup `count_fraction` first
#' # so that the `rtables` formatting function `format_count_fraction()` can be applied correctly.
#' afun <- make_afun(a_count_abnormal_by_marked, .ungroup_stats = "count_fraction")
#' afun(
#'   df = df_crp %>% filter(abn_dir == "High"),
#'   .spl_context = spl_context,
#'   variables = list(id = "USUBJID", param = "PARAMCD", direction = "abn_dir")
#' )
#' }
#'
#' @keywords internal
a_count_abnormal_by_marked <- make_afun(
  s_count_abnormal_by_marked,
  .formats = c(count_fraction = format_count_fraction)
)

#' @describeIn abnormal_by_marked Layout creating function which can be used for creating tables,
#'   which can take statistics function arguments and additional format arguments (see below).
#'
#' @examples
#' map <- unique(
#'   df[df$abn_dir %in% c("Low", "High") & df$AVALCAT1 != "", c("PARAMCD", "abn_dir")]
#' ) %>%
#'   lapply(as.character) %>%
#'   as.data.frame() %>%
#'   arrange(PARAMCD, abn_dir)
#'
#' basic_table() %>%
#'   split_cols_by("ARMCD") %>%
#'   split_rows_by("PARAMCD") %>%
#'   summarize_num_patients(
#'     var = "USUBJID",
#'     .stats = "unique_count"
#'   ) %>%
#'   split_rows_by(
#'     "abn_dir",
#'     split_fun = trim_levels_to_map(map)
#'   ) %>%
#'   count_abnormal_by_marked(
#'     var = "AVALCAT1",
#'     variables = list(
#'       id = "USUBJID",
#'       param = "PARAMCD",
#'       direction = "abn_dir"
#'     )
#'   ) %>%
#'   build_table(df = df)
#'
#'
#' basic_table() %>%
#'   split_cols_by("ARMCD") %>%
#'   split_rows_by("PARAMCD") %>%
#'   summarize_num_patients(
#'     var = "USUBJID",
#'     .stats = "unique_count"
#'   ) %>%
#'   split_rows_by(
#'     "abn_dir",
#'     split_fun = trim_levels_in_group("abn_dir")
#'   ) %>%
#'   count_abnormal_by_marked(
#'     var = "AVALCAT1",
#'     variables = list(
#'       id = "USUBJID",
#'       param = "PARAMCD",
#'       direction = "abn_dir"
#'     )
#'   ) %>%
#'   build_table(df = df)
#'
#' @export
count_abnormal_by_marked <- function(lyt,
                                     var,
                                     ...,
                                     .stats = NULL,
                                     .formats = NULL,
                                     .labels = NULL,
                                     .indent_mods = NULL) {
  checkmate::assert_string(var)

  afun <- make_afun(
    a_count_abnormal_by_marked,
    .stats = .stats,
    .formats = .formats,
    .labels = .labels,
    .indent_mods = .indent_mods,
    .ungroup_stats = "count_fraction"
  )

  lyt <- analyze(
    lyt = lyt,
    vars = var,
    afun = afun,
    show_labels = "hidden",
    extra_args = c(list(...))
  )
  lyt
}

#' Patient Counts with Abnormal Range Values by Baseline Status
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @details
#' Note that `df` should be filtered to include only post-baseline records.
#'
#' Primary analysis variable `.var` indicates the abnormal range result (character or factor), and additional
#' analysis variables are `id` (character or factor) and `baseline` (character or factor). For each
#' direction specified in `abnormal` (e.g. high or low) we condition on baseline range result and count
#' patients in the numerator and denominator as follows:
#'   * `Not <Abnormal>`
#'     * `denom`: the number of patients without abnormality at baseline (excluding those with missing baseline)
#'     * `num`:  the number of patients in `denom` who also have at least one abnormality post-baseline
#'   * `<Abnormal>`
#'     * `denom`: the number of patients with abnormality at baseline
#'     * `num`: the number of patients in `denom` who also have at least one abnormality post-baseline
#'   * `Total`
#'     * `denom`: the number of patients with at least one valid measurement post-baseline
#'     * `num`: the number of patients in `denom` who also have at least one abnormality post-baseline
#'
#' @inheritParams argument_convention
#' @param abnormal (`character`)\cr identifying the abnormal range level(s) in `.var`.
#' @seealso Relevant description function [d_count_abnormal_by_baseline()].
#'
#' @name abnormal_by_baseline
#' @include formats.R
NULL

#' Description Function for [s_count_abnormal_by_baseline()]
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Description function that produces the labels for [s_count_abnormal_by_baseline()].
#'
#' @inheritParams abnormal_by_baseline
#'
#' @examples
#' d_count_abnormal_by_baseline("LOW")
#'
#' @export
d_count_abnormal_by_baseline <- function(abnormal) {
  null_name <- paste0(toupper(substr(abnormal, 1, 1)), tolower(substring(abnormal, 2)))
  not_abn_name <- paste("Not", tolower(abnormal), "baseline status")
  abn_name <- paste(null_name, "baseline status")
  total_name <- "Total"

  list(
    not_abnormal = not_abn_name,
    abnormal = abn_name,
    total = total_name
  )
}

#' @describeIn abnormal_by_baseline For a single `abnormal` level, produce a statistic `fraction` which is
#'   a named list with 3 elements: `not_abnormal`, `abnormal` and `total`.
#'   Each element contains a vector with `num` and `denom` counts of patients.
#'   Please note that if the baseline variable or analysis variable contains `NA`, it is expected that `NA` has been
#'   conveyed to `na_level` appropriately beforehand with `df_explicit_na()` or `explicit_na()`.
#'
#' @param na_level (`string`)\cr the explicit `na_level` argument you used in the pre-processing steps (maybe with
#'   `df_explicit_na()`). The default is `"<Missing>"`.
#'
#' @examples
#' df <- data.frame(
#'   USUBJID = as.character(c(1:6)),
#'   ANRIND = factor(c(rep("LOW", 4), "NORMAL", "HIGH")),
#'   BNRIND = factor(c("LOW", "NORMAL", "HIGH", NA, "LOW", "NORMAL"))
#' )
#' df <- df_explicit_na(df)
#'
#' # Internal function - s_count_abnormal_by_baseline
#' \dontrun{
#' # Just for one abnormal level.
#' s_count_abnormal_by_baseline(df, .var = "ANRIND", abnormal = "HIGH")
#' }
#'
#' @keywords internal
s_count_abnormal_by_baseline <- function(df,
                                         .var,
                                         abnormal,
                                         na_level = "<Missing>",
                                         variables = list(id = "USUBJID", baseline = "BNRIND")) {
  checkmate::assert_string(.var)
  checkmate::assert_string(abnormal)
  checkmate::assert_string(na_level)
  assert_df_with_variables(df, c(range = .var, variables))
  checkmate::assert_subset(names(variables), c("id", "baseline"))
  checkmate::assert_multi_class(df[[variables$id]], classes = c("factor", "character"))
  checkmate::assert_multi_class(df[[variables$baseline]], classes = c("factor", "character"))
  checkmate::assert_multi_class(df[[.var]], classes = c("factor", "character"))

  # If input is passed as character, changed to factor
  df[[.var]] <- as_factor_keep_attributes(df[[.var]], na_level = na_level)
  df[[variables$baseline]] <- as_factor_keep_attributes(df[[variables$baseline]], na_level = na_level)

  assert_valid_factor(df[[.var]], any.missing = FALSE)
  assert_valid_factor(df[[variables$baseline]], any.missing = FALSE)

  # Keep only records with valid analysis value.
  df <- df[df[[.var]] != na_level, ]

  anl <- data.frame(
    id = df[[variables$id]],
    var = df[[.var]],
    baseline = df[[variables$baseline]],
    stringsAsFactors = FALSE
  )

  # Total:
  #  - Patients in denominator: have at least one valid measurement post-baseline.
  #  - Patients in numerator: have at least one abnormality.
  total_denom <- length(unique(anl$id))
  total_num <- length(unique(anl$id[anl$var == abnormal]))

  # Baseline NA records are counted only in total rows.
  anl <- anl[anl$baseline != na_level, ]

  # Abnormal:
  #   - Patients in denominator: have abnormality at baseline.
  #   - Patients in numerator: have abnormality at baseline AND
  #     have at least one abnormality post-baseline.
  abn_denom <- length(unique(anl$id[anl$baseline == abnormal]))
  abn_num <- length(unique(anl$id[anl$baseline == abnormal & anl$var == abnormal]))

  # Not abnormal:
  #   - Patients in denominator: do not have abnormality at baseline.
  #   - Patients in numerator: do not have abnormality at baseline AND
  #     have at least one abnormality post-baseline.
  not_abn_denom <- length(unique(anl$id[anl$baseline != abnormal]))
  not_abn_num <- length(unique(anl$id[anl$baseline != abnormal & anl$var == abnormal]))

  labels <- d_count_abnormal_by_baseline(abnormal)
  list(fraction = list(
    not_abnormal = formatters::with_label(c(num = not_abn_num, denom = not_abn_denom), labels$not_abnormal),
    abnormal = formatters::with_label(c(num = abn_num, denom = abn_denom), labels$abnormal),
    total = formatters::with_label(c(num = total_num, denom = total_denom), labels$total)
  ))
}

#' @describeIn abnormal_by_baseline Formatted Analysis function which can be further customized by calling
#'   [rtables::make_afun()] on it. It is used as `afun` in [rtables::analyze()].
#'
#' @return [a_count_abnormal_by_baseline()] returns the corresponding list with formatted [rtables::CellValue()].
#'
#' @examples
#' # Internal function - a_count_abnormal_by_baseline
#' \dontrun{
#' # Use the Formatted Analysis function for `analyze()`. We need to ungroup `fraction` first
#' # so that the `rtables` formatting function `format_fraction()` can be applied correctly.
#' afun <- make_afun(a_count_abnormal_by_baseline, .ungroup_stats = "fraction")
#' afun(df, .var = "ANRIND", abnormal = "LOW")
#' }
#'
#' @keywords internal
a_count_abnormal_by_baseline <- make_afun(
  s_count_abnormal_by_baseline,
  .formats = c(fraction = format_fraction)
)

#' @describeIn abnormal_by_baseline Layout creating function which can be used for creating tables, which can take
#'   statistics function arguments and additional format arguments (see below).
#'
#' @inheritParams argument_convention
#'
#' @examples
#' # Layout creating function.
#' basic_table() %>%
#'   count_abnormal_by_baseline(var = "ANRIND", abnormal = c(High = "HIGH")) %>%
#'   build_table(df)
#'
#' # Passing of statistics function and formatting arguments.
#' df2 <- data.frame(
#'   ID = as.character(c(1, 2, 3, 4)),
#'   RANGE = factor(c("NORMAL", "LOW", "HIGH", "HIGH")),
#'   BLRANGE = factor(c("LOW", "HIGH", "HIGH", "NORMAL"))
#' )
#'
#' basic_table() %>%
#'   count_abnormal_by_baseline(
#'     var = "RANGE",
#'     abnormal = c(Low = "LOW"),
#'     variables = list(id = "ID", baseline = "BLRANGE"),
#'     .formats = c(fraction = "xx / xx"),
#'     .indent_mods = c(fraction = 2L)
#'   ) %>%
#'   build_table(df2)
#'
#' @export
count_abnormal_by_baseline <- function(lyt,
                                       var,
                                       abnormal,
                                       ...,
                                       table_names = abnormal,
                                       .stats = NULL,
                                       .formats = NULL,
                                       .labels = NULL,
                                       .indent_mods = NULL) {
  checkmate::assert_character(abnormal, len = length(table_names), names = "named")
  checkmate::assert_string(var)
  afun <- make_afun(
    a_count_abnormal_by_baseline,
    .stats = .stats,
    .formats = .formats,
    .labels = .labels,
    .indent_mods = .indent_mods,
    .ungroup_stats = "fraction"
  )
  for (i in seq_along(abnormal)) {
    abn <- abnormal[i]
    lyt <- analyze(
      lyt = lyt,
      vars = var,
      var_labels = names(abn),
      afun = afun,
      table_names = table_names[i],
      extra_args = c(list(abnormal = abn), list(...)),
      show_labels = "visible"
    )
  }
  lyt
}

#' Stack Multiple Grobs
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Stack grobs as a new grob with 1 column and multiple rows layout.
#'
#' @param ... grobs.
#' @param grobs list of grobs.
#' @param padding unit of length 1, space between each grob.
#' @param vp a \code{\link{viewport}} object (or \code{NULL}).
#' @param name a character identifier for the grob.
#' @param gp A \code{\link{gpar}} object.
#' @export
#'
#' @examples
#' library(grid)
#'
#' g1 <- circleGrob(gp = gpar(col = "blue"))
#' g2 <- circleGrob(gp = gpar(col = "red"))
#' g3 <- textGrob("TEST TEXT")
#' grid.newpage()
#' grid.draw(stack_grobs(g1, g2, g3))
#'
#' showViewport()
#'
#' grid.newpage()
#' pushViewport(viewport(layout = grid.layout(1, 2)))
#' vp1 <- viewport(layout.pos.row = 1, layout.pos.col = 2)
#' grid.draw(stack_grobs(g1, g2, g3, vp = vp1, name = "test"))
#'
#' showViewport()
#' grid.ls(grobs = TRUE, viewports = TRUE, print = FALSE)
stack_grobs <- function(...,
                        grobs = list(...),
                        padding = grid::unit(2, "line"),
                        vp = NULL,
                        gp = NULL,
                        name = NULL) {
  checkmate::assert_true(
    all(vapply(grobs, grid::is.grob, logical(1)))
  )

  if (length(grobs) == 1) {
    return(grobs[[1]])
  }

  n_layout <- 2 * length(grobs) - 1
  hts <- lapply(
    seq(1, n_layout),
    function(i) {
      if (i %% 2 != 0) {
        grid::unit(1, "null")
      } else {
        padding
      }
    }
  )
  hts <- do.call(grid::unit.c, hts)

  main_vp <- grid::viewport(
    layout = grid::grid.layout(nrow = n_layout, ncol = 1, heights = hts)
  )

  nested_grobs <- Map(function(g, i) {
    grid::gTree(
      children = grid::gList(g),
      vp = grid::viewport(layout.pos.row = i, layout.pos.col = 1)
    )
  }, grobs, seq_along(grobs) * 2 - 1)

  grobs_mainvp <- grid::gTree(
    children = do.call(grid::gList, nested_grobs),
    vp = main_vp
  )

  grid::gTree(
    children = grid::gList(grobs_mainvp),
    vp = vp,
    gp = gp,
    name = name
  )
}


#' Arrange Multiple Grobs
#'
#' Arrange grobs as a new grob with \verb{n*m (rows*cols)} layout.
#'
#' @inheritParams stack_grobs
#' @param ncol number of columns in layout.
#' @param nrow number of rows in layout.
#' @param padding_ht unit of length 1, vertical space between each grob.
#' @param padding_wt unit of length 1, horizontal space between each grob.
#'
#' @examples
#' library(grid)
#'
#' # Internal function - arrange_grobs
#' \dontrun{
#' num <- lapply(1:9, textGrob)
#' grid::grid.newpage()
#' grid.draw(arrange_grobs(grobs = num, ncol = 2))
#'
#' showViewport()
#'
#' g1 <- circleGrob(gp = gpar(col = "blue"))
#' g2 <- circleGrob(gp = gpar(col = "red"))
#' g3 <- textGrob("TEST TEXT")
#' grid::grid.newpage()
#' grid.draw(arrange_grobs(g1, g2, g3, nrow = 2))
#'
#' showViewport()
#'
#' grid::grid.newpage()
#' grid.draw(arrange_grobs(g1, g2, g3, ncol = 3))
#'
#' grid::grid.newpage()
#' grid::pushViewport(grid::viewport(layout = grid::grid.layout(1, 2)))
#' vp1 <- grid::viewport(layout.pos.row = 1, layout.pos.col = 2)
#' grid.draw(arrange_grobs(g1, g2, g3, ncol = 2, vp = vp1))
#'
#' showViewport()
#' }
#'
#' @keywords internal
arrange_grobs <- function(..., # nolint
                          grobs = list(...),
                          ncol = NULL, nrow = NULL,
                          padding_ht = grid::unit(2, "line"),
                          padding_wt = grid::unit(2, "line"),
                          vp = NULL,
                          gp = NULL,
                          name = NULL) {
  checkmate::assert_true(
    all(vapply(grobs, grid::is.grob, logical(1)))
  )

  if (length(grobs) == 1) {
    return(grobs[[1]])
  }

  if (is.null(ncol) && is.null(nrow)) {
    ncol <- 1
    nrow <- ceiling(length(grobs) / ncol)
  } else if (!is.null(ncol) && is.null(nrow)) {
    nrow <- ceiling(length(grobs) / ncol)
  } else if (is.null(ncol) && !is.null(nrow)) {
    ncol <- ceiling(length(grobs) / nrow)
  }

  if (ncol * nrow < length(grobs)) {
    stop("specififed ncol and nrow are not enough for arranging the grobs ")
  }

  if (ncol == 1) {
    return(stack_grobs(grobs = grobs, padding = padding_ht, vp = vp, gp = gp, name = name))
  }

  n_col <- 2 * ncol - 1
  n_row <- 2 * nrow - 1
  hts <- lapply(
    seq(1, n_row),
    function(i) {
      if (i %% 2 != 0) {
        grid::unit(1, "null")
      } else {
        padding_ht
      }
    }
  )
  hts <- do.call(grid::unit.c, hts)

  wts <- lapply(
    seq(1, n_col),
    function(i) {
      if (i %% 2 != 0) {
        grid::unit(1, "null")
      } else {
        padding_wt
      }
    }
  )
  wts <- do.call(grid::unit.c, wts)

  main_vp <- grid::viewport(
    layout = grid::grid.layout(nrow = n_row, ncol = n_col, widths = wts, heights = hts)
  )

  nested_grobs <- list()
  k <- 0
  for (i in seq(nrow) * 2 - 1) {
    for (j in seq(ncol) * 2 - 1) {
      k <- k + 1
      if (k <= length(grobs)) {
        nested_grobs <- c(
          nested_grobs,
          list(grid::gTree(
            children = grid::gList(grobs[[k]]),
            vp = grid::viewport(layout.pos.row = i, layout.pos.col = j)
          ))
        )
      }
    }
  }
  grobs_mainvp <- grid::gTree(
    children = do.call(grid::gList, nested_grobs),
    vp = main_vp
  )

  grid::gTree(
    children = grid::gList(grobs_mainvp),
    vp = vp,
    gp = gp,
    name = name
  )
}



#' Draw `grob`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Draw grob on device page.
#'
#' @param grob grid object
#' @param newpage draw on a new page
#' @param vp a \code{\link{viewport}} object (or \code{NULL}).
#' @export
#'
#' @examples
#' library(dplyr)
#' library(grid)
#'
#' # Internal function - arrange_grob
#' \dontrun{
#' rect <- rectGrob(width = grid::unit(0.5, "npc"), height = grid::unit(0.5, "npc"))
#' rect %>% draw_grob(vp = grid::viewport(angle = 45))
#'
#' num <- lapply(1:10, textGrob)
#' num %>%
#'   arrange_grobs(grobs = .) %>%
#'   draw_grob()
#' showViewport()
#' }
draw_grob <- function(grob, newpage = TRUE, vp = NULL) {
  if (newpage) {
    grid::grid.newpage()
  }
  if (!is.null(vp)) {
    grid::pushViewport(vp)
  }
  grid::grid.draw(grob)
}

tern_grob <- function(x) { # nolint
  class(x) <- unique(c("ternGrob", class(x)))
  x
}

print.ternGrob <- function(x, ...) { # nolint
  grid::grid.newpage()
  grid::grid.draw(x)
}

#' Patient Counts with Abnormal Range Values
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Primary analysis variable `.var` indicates the abnormal range result (`character` or `factor`)
#' and additional analysis variables are `id` (`character` or `factor`) and `baseline` (`character` or
#' `factor`). For each direction specified in `abnormal` (e.g. high or low) count patients in the
#' numerator and denominator as follows:
#' \describe{
#'   \item{num}{the number of patients with this abnormality recorded while on treatment.}
#'   \item{denom}{the number of patients with at least one post-baseline assessment.}
#' }
#' Note, the denominator includes patients that might have other abnormal levels at baseline,
#' and patients with missing baseline. Note, optionally patients with this abnormality at
#' baseline can be excluded from numerator and denominator.
#'
#' @details Note that `df` should be filtered to include only post-baseline records.
#'
#' @inheritParams argument_convention
#' @param abnormal (`named list`)\cr identifying the abnormal range level(s) in `var`. Default to
#' `list(Low = "LOW", High = "HIGH")` but you can also group different levels into the name list,
#' for example, `abnormal = list(Low = c("LOW", "LOW LOW"), High = c("HIGH", "HIGH HIGH"))`
#'
#' @name abnormal
#' @include formats.R
NULL

#' @describeIn abnormal Statistics function which counts patients with abnormal range values
#'   for a single `abnormal` level.
#' @param exclude_base_abn (`flag`)\cr whether to exclude subjects with baseline abnormality
#'   from numerator and denominator.
#' @return [s_count_abnormal()] returns the statistic `fraction` which is a
#'   vector with `num` and `denom` counts of patients.
#'
#' @examples
#' library(dplyr)
#'
#' df <- data.frame(
#'   USUBJID = as.character(c(1, 1, 2, 2)),
#'   ANRIND = factor(c("NORMAL", "LOW", "HIGH", "HIGH")),
#'   BNRIND = factor(c("NORMAL", "NORMAL", "HIGH", "HIGH")),
#'   ONTRTFL = c("", "Y", "", "Y"),
#'   stringsAsFactors = FALSE
#' )
#'
#' # Select only post-baseline records.
#' df <- df %>%
#'   filter(ONTRTFL == "Y")
#'
#' # Internal function - s_count_abnormal
#' \dontrun{
#' # For abnormal level "HIGH" we get the following counts.
#' s_count_abnormal(df, .var = "ANRIND", abnormal = list(high = "HIGH", low = "LOW"))
#'
#' # Optionally exclude patients with abnormality at baseline.
#' s_count_abnormal(
#'   df,
#'   .var = "ANRIND",
#'   abnormal = list(high = "HIGH", low = "LOW"),
#'   exclude_base_abn = TRUE
#' )
#' }
#'
#' @keywords internal
s_count_abnormal <- function(df,
                             .var,
                             abnormal = list(Low = "LOW", High = "HIGH"),
                             variables = list(id = "USUBJID", baseline = "BNRIND"),
                             exclude_base_abn = FALSE) {
  checkmate::assert_list(abnormal, types = "character", names = "named", len = 2, any.missing = FALSE)
  checkmate::assert_true(any(unlist(abnormal) %in% levels(df[[.var]])))
  checkmate::assert_factor(df[[.var]])
  checkmate::assert_flag(exclude_base_abn)
  assert_df_with_variables(df, c(range = .var, variables))
  checkmate::assert_multi_class(df[[variables$baseline]], classes = c("factor", "character"))
  checkmate::assert_multi_class(df[[variables$id]], classes = c("factor", "character"))

  count_abnormal_single <- function(abn_name, abn) {
    # Patients in the denominator fulfill:
    # - have at least one post-baseline visit
    # - their baseline must not be abnormal if `exclude_base_abn`.
    if (exclude_base_abn) {
      denom_select <- !(df[[variables$baseline]] %in% abn)
    } else {
      denom_select <- TRUE
    }
    denom <- length(unique(df[denom_select, variables$id, drop = TRUE]))

    # Patients in the numerator fulfill:
    # - have at least one post-baseline visit with the required abnormality level
    # - are part of the denominator patients.
    num_select <- (df[[.var]] %in% abn) & denom_select
    num <- length(unique(df[num_select, variables$id, drop = TRUE]))

    formatters::with_label(c(num = num, denom = denom), abn_name)
  }

  # This will define the abnormal levels theoretically possible for a specific lab parameter
  # within a split level of a layout.
  abnormal_lev <- lapply(abnormal, intersect, levels(df[[.var]]))
  abnormal_lev <- abnormal_lev[vapply(abnormal_lev, function(x) length(x) > 0, logical(1))]

  result <- sapply(names(abnormal_lev), function(i) count_abnormal_single(i, abnormal_lev[[i]]), simplify = FALSE)
  result <- list(fraction = result)
  result
}

#' @describeIn abnormal Formatted Analysis function which can be further customized by calling
#'   [rtables::make_afun()] on it. It is used as `afun` in [rtables::analyze()].
#'
#' @return [a_count_abnormal()] returns the corresponding list with formatted [rtables::CellValue()].
#'
#' @examples
#' # Internal function - a_count_abnormal
#' \dontrun{
#' # Use the Formatted Analysis function for `analyze()`.
#' a_fun <- make_afun(a_count_abnormal, .ungroup_stats = "fraction")
#' a_fun(df, .var = "ANRIND", abnormal = list(low = "LOW", high = "HIGH"))
#' }
#'
#' @keywords internal
a_count_abnormal <- make_afun(
  s_count_abnormal,
  .formats = c(fraction = format_fraction)
)

#' @describeIn abnormal Layout creating function which can be used for creating tables, which can take
#'   statistics function arguments and additional format arguments (see below). Note that it only
#'   works with a single variable but multiple abnormal levels.
#' @return [count_abnormal()] can be used with multiple abnormal levels and modifies the layout.
#' @export
#' @examples
#' # Layout creating function.
#' basic_table() %>%
#'   count_abnormal(var = "ANRIND", abnormal = list(high = "HIGH", low = "LOW")) %>%
#'   build_table(df)
#'
#' # Passing of statistics function and formatting arguments.
#' df2 <- data.frame(
#'   ID = as.character(c(1, 1, 2, 2)),
#'   RANGE = factor(c("NORMAL", "LOW", "HIGH", "HIGH")),
#'   BL_RANGE = factor(c("NORMAL", "NORMAL", "HIGH", "HIGH")),
#'   ONTRTFL = c("", "Y", "", "Y"),
#'   stringsAsFactors = FALSE
#' )
#'
#' # Select only post-baseline records.
#' df2 <- df2 %>%
#'   filter(ONTRTFL == "Y")
#'
#' basic_table() %>%
#'   count_abnormal(
#'     var = "RANGE",
#'     abnormal = list(low = "LOW", high = "HIGH"),
#'     variables = list(id = "ID", baseline = "BL_RANGE")
#'   ) %>%
#'   build_table(df2)
count_abnormal <- function(lyt,
                           var,
                           ...,
                           table_names = var,
                           .stats = NULL,
                           .formats = NULL,
                           .labels = NULL,
                           .indent_mods = NULL) {
  afun <- make_afun(
    a_count_abnormal,
    .stats = .stats,
    .formats = .formats,
    .labels = .labels,
    .indent_mods = .indent_mods,
    .ungroup_stats = "fraction"
  )

  checkmate::assert_string(var)

  analyze(
    lyt = lyt,
    vars = var,
    afun = afun,
    table_names = table_names,
    extra_args = list(...),
    show_labels = "hidden"
  )
}

#' Assign Footnotes
#'
#' @description `r lifecycle::badge("deprecated")`
#'
#' Assign value to attribute footnote of object `x`.
#'
#' This function is deprecated and will be removed from `tern` in version 0.7.11.
#' Please use the equivalent implementation from `rtables` or `attr(x, "footnote")` directly.
#'
#' @param x an object
#' @param value character vector
#' @export
#' @examples
#' x <- table(iris$Species)
#' footnotes(x) <- "Species are equally distributed"
#' attributes(x)
`footnotes<-` <- function(x, value = NULL) { # nolint
  dep_msg <- 'Please use current implementation in rtables or directly attr(x, "footnote")'
  lifecycle::deprecate_warn("0.7.11", "footnotes()", details = dep_msg)
  attr(x, "footnote") <- value
  x
}

#' Retrieve Footnotes
#'
#' @description `r lifecycle::badge("deprecated")`
#'
#' Retrieve value from attribute `footnote` of object `x`.
#'
#' This function is deprecated and will be removed from `tern` in version 0.7.11.
#' Please use the equivalent implementation from `rtables` or `attr(x, "footnote")` directly.
#'
#' @param x an object
#' @export
#' @examples
#' x <- table(iris$Species)
#' footnotes(x) <- "Species are equally distributed"
#' footnotes(x)
footnotes <- function(x) {
  dep_msg <- 'Please use current implementation in rtables or directly attr(x, "footnote")'
  lifecycle::deprecate_warn("0.7.11", "footnotes()", details = dep_msg)
  attr(x, "footnote")
}

#' Add Footnotes
#'
#' @description `r lifecycle::badge("deprecated")`
#'
#' This adds more footnotes.
#'
#' This function is deprecated and will be removed from `tern` in version 0.7.11.
#' Please use the equivalent implementation from `rtables` or `attr(x, "footnote")` directly.
#'
#' @param x an object
#' @param value character vector
#' @export
#' @examples
#' x <- table(iris$Species)
#' footnotes(x) <- "Species are equally distributed"
#' footnotes(x)
#' add_footnotes(x) <- "Add more footnotes"
#' footnotes(x)
`add_footnotes<-` <- function(x, value) { # nolint
  dep_msg <- 'Please use current implementation in rtables or directly attr(x, "footnote")'
  lifecycle::deprecate_warn("0.7.11", "add_footnotes()", details = dep_msg)
  footnotes(x) <- c(footnotes(x), value)
  x
}

#' Create a Forest Plot based on a Table
#'
#' Create a forest plot from any [rtables::rtable()] object that has a
#' column with a single value and a column with 2 values.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @inheritParams argument_convention
#' @param tbl (`rtable`)
#' @param col_x (`integer`)\cr column index with estimator. By default tries to get this from
#'   `tbl` attribute `col_x`, otherwise needs to be manually specified.
#' @param col_ci (`integer`)\cr column index with confidence intervals. By default tries
#'   to get this from `tbl` attribute `col_ci`, otherwise needs to be manually specified.
#' @param vline (`number`)\cr x coordinate for vertical line, if `NULL` then the line is omitted.
#' @param forest_header (`character`, length 2)\cr text displayed to the left and right of `vline`, respectively.
#'   If `vline = NULL` then `forest_header` needs to be `NULL` too.
#'   By default tries to get this from `tbl` attribute `forest_header`.
#' @param xlim (`numeric`)\cr limits for x axis.
#' @param logx (`flag`)\cr show the x-values on logarithm scale.
#' @param x_at (`numeric`)\cr x-tick locations, if `NULL` they get automatically chosen.
#' @param width_row_names (`unit`)\cr width for row names.
#'   If `NULL` the widths get automatically calculated. See [grid::unit()].
#' @param width_columns (`unit`)\cr widths for the table columns.
#'   If `NULL` the widths get automatically calculated. See [grid::unit()].
#' @param width_forest (`unit`)\cr width for the forest column.
#'   If `NULL` the widths get automatically calculated. See [grid::unit()].
#' @param col_symbol_size (`integer`)\cr column index from `tbl` containing data to be used
#'   to determine relative size for estimator plot symbol. Typically, the symbol size is proportional
#'   to the sample size used to calculate the estimator. If `NULL`, the same symbol size is used for all subgroups.
#'   By default tries to get this from `tbl` attribute `col_symbol_size`, otherwise needs to be manually specified.
#' @param col (`character`)\cr color(s).
#' @return `gtree` object containing the forest plot and table
#' @export
#'
#' @examples
#' \dontrun{
#' library(dplyr)
#' library(forcats)
#' library(nestcolor)
#'
#' adrs <- tern_ex_adrs
#' n_records <- 20
#' adrs_labels <- formatters::var_labels(adrs, fill = TRUE)
#' adrs <- adrs %>%
#'   filter(PARAMCD == "BESRSPI") %>%
#'   filter(ARM %in% c("A: Drug X", "B: Placebo")) %>%
#'   slice(seq_len(n_records)) %>%
#'   droplevels() %>%
#'   mutate(
#'     # Reorder levels of factor to make the placebo group the reference arm.
#'     ARM = fct_relevel(ARM, "B: Placebo"),
#'     rsp = AVALC == "CR"
#'   )
#' formatters::var_labels(adrs) <- c(adrs_labels, "Response")
#' df <- extract_rsp_subgroups(
#'   variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "STRATA2")),
#'   data = adrs
#' )
#' # Full commonly used response table.
#'
#' tbl <- basic_table() %>%
#'   tabulate_rsp_subgroups(df)
#' p <- g_forest(tbl)
#'
#' draw_grob(p)
#'
#' # Odds ratio only table.
#'
#' tbl_or <- basic_table() %>%
#'   tabulate_rsp_subgroups(df, vars = c("n_tot", "or", "ci"))
#' tbl_or
#' p <- g_forest(
#'   tbl_or,
#'   forest_header = c("Comparison\nBetter", "Treatment\nBetter")
#' )
#'
#' draw_grob(p)
#'
#' # Survival forest plot example.
#' adtte <- tern_ex_adtte
#' # Save variable labels before data processing steps.
#' adtte_labels <- formatters::var_labels(adtte, fill = TRUE)
#' adtte_f <- adtte %>%
#'   filter(
#'     PARAMCD == "OS",
#'     ARM %in% c("B: Placebo", "A: Drug X"),
#'     SEX %in% c("M", "F")
#'   ) %>%
#'   mutate(
#'     # Reorder levels of ARM to display reference arm before treatment arm.
#'     ARM = droplevels(fct_relevel(ARM, "B: Placebo")),
#'     SEX = droplevels(SEX),
#'     AVALU = as.character(AVALU),
#'     is_event = CNSR == 0
#'   )
#' labels <- list(
#'   "ARM" = adtte_labels["ARM"],
#'   "SEX" = adtte_labels["SEX"],
#'   "AVALU" = adtte_labels["AVALU"],
#'   "is_event" = "Event Flag"
#' )
#' formatters::var_labels(adtte_f)[names(labels)] <- as.character(labels)
#' df <- extract_survival_subgroups(
#'   variables = list(
#'     tte = "AVAL",
#'     is_event = "is_event",
#'     arm = "ARM", subgroups = c("SEX", "BMRKR2")
#'   ),
#'   data = adtte_f
#' )
#' table_hr <- basic_table() %>%
#'   tabulate_survival_subgroups(df, time_unit = adtte_f$AVALU[1])
#' g_forest(table_hr)
#' # Works with any `rtable`.
#' tbl <- rtable(
#'   header = c("E", "CI", "N"),
#'   rrow("", 1, c(.8, 1.2), 200),
#'   rrow("", 1.2, c(1.1, 1.4), 50)
#' )
#' g_forest(
#'   tbl = tbl,
#'   col_x = 1,
#'   col_ci = 2,
#'   xlim = c(0.5, 2),
#'   x_at = c(0.5, 1, 2),
#'   col_symbol_size = 3
#' )
#' tbl <- rtable(
#'   header = rheader(
#'     rrow("", rcell("A", colspan = 2)),
#'     rrow("", "c1", "c2")
#'   ),
#'   rrow("row 1", 1, c(.8, 1.2)),
#'   rrow("row 2", 1.2, c(1.1, 1.4))
#' )
#' g_forest(
#'   tbl = tbl,
#'   col_x = 1,
#'   col_ci = 2,
#'   xlim = c(0.5, 2),
#'   x_at = c(0.5, 1, 2),
#'   vline = 1,
#'   forest_header = c("Hello", "World")
#' )
#' }
g_forest <- function(tbl, # nolint
                     col_x = attr(tbl, "col_x"),
                     col_ci = attr(tbl, "col_ci"),
                     vline = 1,
                     forest_header = attr(tbl, "forest_header"),
                     xlim = c(0.1, 10),
                     logx = TRUE,
                     x_at = c(0.1, 1, 10),
                     width_row_names = NULL,
                     width_columns = NULL,
                     width_forest = grid::unit(1, "null"),
                     col_symbol_size = attr(tbl, "col_symbol_size"),
                     col = getOption("ggplot2.discrete.colour")[1],
                     draw = TRUE,
                     newpage = TRUE) {
  checkmate::assert_class(tbl, "VTableTree")

  nr <- nrow(tbl)
  nc <- ncol(tbl)
  if (is.null(col)) {
    col <- "blue"
  }

  checkmate::assert_number(col_x, lower = 0, upper = nc, null.ok = FALSE)
  checkmate::assert_number(col_ci, lower = 0, upper = nc, null.ok = FALSE)
  checkmate::assert_number(col_symbol_size, lower = 0, upper = nc, null.ok = TRUE)
  checkmate::assert_true(col_x > 0)
  checkmate::assert_true(col_ci > 0)
  checkmate::assert_character(col)
  if (!is.null(col_symbol_size)) {
    checkmate::assert_true(col_symbol_size > 0)
  }

  x_e <- vapply(seq_len(nr), function(i) {
    # If a label row is selected NULL is returned with a warning (suppressed)
    xi <- suppressWarnings(as.vector(tbl[i, col_x, drop = TRUE]))

    if (!is.null(xi) && !(length(xi) <= 0) && is.numeric(xi)) {
      xi
    } else {
      NA_real_
    }
  }, numeric(1))

  x_ci <- lapply(seq_len(nr), function(i) {
    xi <- suppressWarnings(as.vector(tbl[i, col_ci, drop = TRUE])) # as above

    if (!is.null(xi) && !(length(xi) <= 0) && is.numeric(xi)) {
      if (length(xi) != 2) {
        stop("ci column needs two elements")
      }
      xi
    } else {
      c(NA_real_, NA_real_)
    }
  })

  lower <- vapply(x_ci, `[`, numeric(1), 1)
  upper <- vapply(x_ci, `[`, numeric(1), 2)

  symbol_size <- if (!is.null(col_symbol_size)) {
    tmp_symbol_size <- vapply(seq_len(nr), function(i) {
      suppressWarnings(xi <- as.vector(tbl[i, col_symbol_size, drop = TRUE]))

      if (!is.null(xi) && !(length(xi) <= 0) && is.numeric(xi)) {
        xi
      } else {
        NA_real_
      }
    }, numeric(1))

    # Scale symbol size.
    tmp_symbol_size <- sqrt(tmp_symbol_size)
    max_size <- max(tmp_symbol_size, na.rm = TRUE)
    # Biggest points have radius is 2 * (1/3.5) lines not to overlap.
    # See forest_dot_line.
    2 * tmp_symbol_size / max_size
  } else {
    NULL
  }

  grob_forest <- forest_grob(
    tbl,
    x_e,
    lower,
    upper,
    vline,
    forest_header,
    xlim,
    logx,
    x_at,
    width_row_names,
    width_columns,
    width_forest,
    symbol_size = symbol_size,
    col = col,
    vp = grid::plotViewport(margins = rep(1, 4))
  )

  if (draw) {
    if (newpage) grid::grid.newpage()
    grid::grid.draw(grob_forest)
  }

  invisible(grob_forest)
}

#' Forest Plot Grob
#'
#' @inheritParams g_forest
#' @param tbl ([rtables::rtable()])
#' @param x (`numeric`)\cr coordinate of point.
#' @param lower,upper (`numeric`)\cr lower/upper bound of the confidence interval.
#' @param symbol_size (`numeric`)\cr vector with relative size for plot symbol.
#' If `NULL`, the same symbol size is used.
#'
#' @details
#' The heights get automatically determined.
#'
#' @noRd
#'
#' @examples
#' tbl <- rtable(
#'   header = rheader(
#'     rrow("", "E", rcell("CI", colspan = 2), "N"),
#'     rrow("", "A", "B", "C", "D")
#'   ),
#'   rrow("row 1", 1, 0.8, 1.1, 16),
#'   rrow("row 2", 1.4, 0.8, 1.6, 25),
#'   rrow("row 3", 1.2, 0.8, 1.6, 36)
#' )
#'
#' x <- c(1, 1.4, 1.2)
#' lower <- c(0.8, 0.8, 0.8)
#' upper <- c(1.1, 1.6, 1.6)
#' # numeric vector with multiplication factor to scale each circle radius
#' # default radius is 1/3.5 lines
#' symbol_scale <- c(1, 1.25, 1.5)
#'
#' # Internal function - forest_grob
#' \dontrun{
#' p <- forest_grob(tbl, x, lower, upper,
#'   vline = 1, forest_header = c("A", "B"),
#'   x_at = c(.1, 1, 10), xlim = c(0.1, 10), logx = TRUE, symbol_size = symbol_scale,
#'   vp = grid::plotViewport(margins = c(1, 1, 1, 1))
#' )
#'
#' draw_grob(p)
#' }
forest_grob <- function(tbl,
                        x,
                        lower,
                        upper,
                        vline,
                        forest_header,
                        xlim = NULL,
                        logx = FALSE,
                        x_at = NULL,
                        width_row_names = NULL,
                        width_columns = NULL,
                        width_forest = grid::unit(1, "null"),
                        symbol_size = NULL,
                        col = "blue",
                        name = NULL,
                        gp = NULL,
                        vp = NULL) {
  nr <- nrow(tbl)
  if (is.null(vline)) {
    checkmate::assert_true(is.null(forest_header))
  } else {
    checkmate::assert_number(vline)
    checkmate::assert_character(forest_header, len = 2, null.ok = TRUE)
  }

  checkmate::assert_numeric(x, len = nr)
  checkmate::assert_numeric(lower, len = nr)
  checkmate::assert_numeric(upper, len = nr)
  checkmate::assert_numeric(symbol_size, len = nr, null.ok = TRUE)
  checkmate::assert_character(col)

  if (is.null(symbol_size)) {
    symbol_size <- rep(1, nr)
  }

  if (is.null(xlim)) {
    r <- range(c(x, lower, upper), na.rm = TRUE)
    xlim <- r + c(-0.05, 0.05) * diff(r)
  }

  if (logx) {
    if (is.null(x_at)) {
      x_at <- pretty(log(stats::na.omit(c(x, lower, upper))))
      x_labels <- exp(x_at)
    } else {
      x_labels <- x_at
      x_at <- log(x_at)
    }
    xlim <- log(xlim)
    x <- log(x)
    lower <- log(lower)
    upper <- log(upper)
    if (!is.null(vline)) {
      vline <- log(vline)
    }
  } else {
    x_labels <- TRUE
  }

  data_forest_vp <- grid::dataViewport(xlim, c(0, 1))

  # Get table content as matrix form.
  mf <- matrix_form(tbl)

  # Use `rtables` indent_string eventually.
  mf$strings[, 1] <- paste0(
    strrep("    ", c(rep(0, attr(mf, "nrow_header")), mf$row_info$indent)),
    mf$strings[, 1]
  )

  n_header <- attr(mf, "nrow_header")

  if (any(mf$display[, 1] == FALSE)) stop("row names need to be always displayed")

  # Pre-process the data to be used in lapply and cell_in_rows.
  to_args_for_cell_in_rows_fun <- function(part = c("body", "header"),
                                           underline_colspan = FALSE) {
    part <- match.arg(part)
    if (part == "body") {
      mat_row_indices <- seq_len(nrow(tbl)) + n_header
      row_ind_offset <- -n_header
    } else {
      mat_row_indices <- seq_len(n_header)
      row_ind_offset <- 0
    }

    lapply(mat_row_indices, function(i) {
      disp <- mf$display[i, -1]
      list(
        row_name = mf$strings[i, 1],
        cells = mf$strings[i, -1][disp],
        cell_spans = mf$spans[i, -1][disp],
        row_index = i + row_ind_offset,
        underline_colspan = underline_colspan
      )
    })
  }

  args_header <- to_args_for_cell_in_rows_fun("header", underline_colspan = TRUE)
  args_body <- to_args_for_cell_in_rows_fun("body", underline_colspan = FALSE)

  grid::gTree(
    name = name,
    children = grid::gList(
      grid::gTree(
        children = do.call(grid::gList, lapply(args_header, do.call, what = cell_in_rows)),
        vp = grid::vpPath("vp_table_layout", "vp_header")
      ),
      grid::gTree(
        children = do.call(grid::gList, lapply(args_body, do.call, what = cell_in_rows)),
        vp = grid::vpPath("vp_table_layout", "vp_body")
      ),
      grid::linesGrob(
        grid::unit(c(0, 1), "npc"),
        y = grid::unit(c(.5, .5), "npc"),
        vp = grid::vpPath("vp_table_layout", "vp_spacer")
      ),
      # forest part
      if (is.null(vline)) {
        NULL
      } else {
        grid::gTree(
          children = grid::gList(
            grid::gTree(
              children = grid::gList(
                # this may overflow, to fix, look here
                # https://stackoverflow.com/questions/33623169/add-multi-line-footnote-to-tablegrob-while-using-gridextra-in-r #nolintr
                grid::textGrob(
                  forest_header[1],
                  x = grid::unit(vline, "native") - grid::unit(1, "lines"),
                  just = c("right", "center")
                ),
                grid::textGrob(
                  forest_header[2],
                  x = grid::unit(vline, "native") + grid::unit(1, "lines"),
                  just = c("left", "center")
                )
              ),
              vp = grid::vpStack(grid::viewport(layout.pos.col = ncol(tbl) + 2), data_forest_vp)
            )
          ),
          vp = grid::vpPath("vp_table_layout", "vp_header")
        )
      },
      grid::gTree(
        children = grid::gList(
          grid::gTree(
            children = grid::gList(
              grid::rectGrob(gp = grid::gpar(col = "gray90", fill = "gray90")),
              if (is.null(vline)) {
                NULL
              } else {
                grid::linesGrob(
                  x = grid::unit(rep(vline, 2), "native"),
                  y = grid::unit(c(0, 1), "npc"),
                  gp = grid::gpar(lwd = 2),
                  vp = data_forest_vp
                )
              },
              grid::xaxisGrob(at = x_at, label = x_labels, vp = data_forest_vp)
            ),
            vp = grid::viewport(layout.pos.col = ncol(tbl) + 2)
          )
        ),
        vp = grid::vpPath("vp_table_layout", "vp_body")
      ),
      grid::gTree(
        children = do.call(
          grid::gList,
          Map(
            function(xi, li, ui, row_index, size_i, col) {
              forest_dot_line(
                xi,
                li,
                ui,
                row_index,
                xlim,
                symbol_size = size_i,
                col = col,
                datavp = data_forest_vp
              )
            },
            x,
            lower,
            upper,
            seq_along(x),
            symbol_size,
            col,
            USE.NAMES = FALSE
          )
        ),
        vp = grid::vpPath("vp_table_layout", "vp_body")
      )
    ),
    childrenvp = forest_viewport(tbl, width_row_names, width_columns, width_forest),
    vp = vp,
    gp = gp
  )
}


cell_in_rows <- function(row_name,
                         cells,
                         cell_spans,
                         row_index,
                         underline_colspan = FALSE) {
  checkmate::assert_string(row_name)
  checkmate::assert_character(cells, min.len = 1, any.missing = FALSE)
  checkmate::assert_numeric(cell_spans, len = length(cells), any.missing = FALSE)
  checkmate::assert_number(row_index)
  checkmate::assert_flag(underline_colspan)

  vp_name_rn <- paste0("rowname-", row_index)
  g_rowname <- if (!is.null(row_name) && row_name != "") {
    grid::textGrob(
      name = vp_name_rn,
      label = row_name,
      x = grid::unit(0, "npc"),
      just = c("left", "center"),
      vp = grid::vpPath(paste0("rowname-", row_index))
    )
  } else {
    NULL
  }

  gl_cols <- if (!(length(cells) > 0)) {
    list(NULL)
  } else {
    j <- 1 # column index of cell

    lapply(seq_along(cells), function(k) {
      cell_ascii <- cells[[k]]
      cs <- cell_spans[[k]]

      if (is.na(cell_ascii) || is.null(cell_ascii)) {
        cell_ascii <- "NA"
      }

      cell_name <- paste0("g-cell-", row_index, "-", j)

      cell_grobs <- if (identical(cell_ascii, "")) {
        NULL
      } else {
        if (cs == 1) {
          grid::textGrob(
            label = cell_ascii,
            name = cell_name,
            vp = grid::vpPath(paste0("cell-", row_index, "-", j))
          )
        } else {
          # +1 because of rowname
          vp_joined_cols <- grid::viewport(layout.pos.row = row_index, layout.pos.col = seq(j + 1, j + cs))

          lab <- grid::textGrob(
            label = cell_ascii,
            name = cell_name,
            vp = vp_joined_cols
          )

          if (!underline_colspan || grepl("^[[:space:]]*$", cell_ascii)) {
            lab
          } else {
            grid::gList(
              lab,
              grid::linesGrob(
                x = grid::unit.c(grid::unit(.2, "lines"), grid::unit(1, "npc") - grid::unit(.2, "lines")),
                y = grid::unit(c(0, 0), "npc"),
                vp = vp_joined_cols
              )
            )
          }
        }
      }
      j <<- j + cs

      cell_grobs
    })
  }

  grid::gList(
    g_rowname,
    do.call(grid::gList, gl_cols)
  )
}

#' Graphic Object: Forest Dot Line
#'
#' Calculate the `grob` corresponding to the dot line within the forest plot.
#'
#' @noRd
forest_dot_line <- function(x, # nolint
                            lower,
                            upper,
                            row_index,
                            xlim,
                            symbol_size = 1,
                            col = "blue",
                            datavp) {
  ci <- c(lower, upper)
  if (any(!is.na(c(x, ci)))) {
    # line
    y <- grid::unit(c(0.5, 0.5), "npc")

    g_line <- if (all(!is.na(ci)) && ci[2] > xlim[1] && ci[1] < xlim[2]) {
      # -
      if (ci[1] >= xlim[1] && ci[2] <= xlim[2]) {
        grid::linesGrob(x = grid::unit(c(ci[1], ci[2]), "native"), y = y)
      } else if (ci[1] < xlim[1] && ci[2] > xlim[2]) {
        # <->
        grid::linesGrob(
          x = grid::unit(xlim, "native"),
          y = y,
          arrow = grid::arrow(angle = 30, length = grid::unit(0.5, "lines"), ends = "both")
        )
      } else if (ci[1] < xlim[1] && ci[2] <= xlim[2]) {
        # <-
        grid::linesGrob(
          x = grid::unit(c(xlim[1], ci[2]), "native"),
          y = y,
          arrow = grid::arrow(angle = 30, length = grid::unit(0.5, "lines"), ends = "first")
        )
      } else if (ci[1] >= xlim[1] && ci[2] > xlim[2]) {
        # ->
        grid::linesGrob(
          x = grid::unit(c(ci[1], xlim[2]), "native"),
          y = y,
          arrow = grid::arrow(angle = 30, length = grid::unit(0.5, "lines"), ends = "last")
        )
      }
    } else {
      NULL
    }

    g_circle <- if (!is.na(x) && x >= xlim[1] && x <= xlim[2]) {
      grid::circleGrob(
        x = grid::unit(x, "native"),
        y = y,
        r = grid::unit(1 / 3.5 * symbol_size, "lines"),
        name = "point"
      )
    } else {
      NULL
    }

    grid::gTree(
      children = grid::gList(
        grid::gTree(
          children = grid::gList(
            grid::gList(
              g_line,
              g_circle
            )
          ),
          vp = datavp,
          gp = grid::gpar(col = col, fill = col)
        )
      ),
      vp = grid::vpPath(paste0("forest-", row_index))
    )
  } else {
    NULL
  }
}

#' Create a Viewport Tree for the Forest Plot
#'
#' @examples
#' library(grid)
#'
#' tbl <- rtable(
#'   header = rheader(
#'     rrow("", "E", rcell("CI", colspan = 2)),
#'     rrow("", "A", "B", "C")
#'   ),
#'   rrow("row 1", 1, 0.8, 1.1),
#'   rrow("row 2", 1.4, 0.8, 1.6),
#'   rrow("row 3", 1.2, 0.8, 1.2)
#' )
#'
#' # Internal function - forest_viewport
#' \dontrun{
#' v <- forest_viewport(tbl)
#'
#' grid::grid.newpage()
#' showViewport(v)
#' }
#'
#' @keywords internal
forest_viewport <- function(tbl,
                            width_row_names = NULL,
                            width_columns = NULL,
                            width_forest = grid::unit(1, "null"),
                            gap_column = grid::unit(1, "lines"),
                            gap_header = grid::unit(1, "lines"),
                            mat_form = NULL) {
  checkmate::assert_class(tbl, "VTableTree")
  checkmate::assert_true(grid::is.unit(width_forest))
  if (!is.null(width_row_names)) {
    checkmate::assert_true(grid::is.unit(width_row_names))
  }
  if (!is.null(width_columns)) {
    checkmate::assert_true(grid::is.unit(width_columns))
  }

  if (is.null(mat_form)) mat_form <- matrix_form(tbl)

  mat_form$strings[!mat_form$display] <- ""

  nr <- nrow(tbl)
  nc <- ncol(tbl)
  nr_h <- attr(mat_form, "nrow_header")

  if (is.null(width_row_names) || is.null(width_columns)) {
    tbl_widths <- formatters::propose_column_widths(mat_form)
    strs_with_width <- strrep("x", tbl_widths) # that works for mono spaced fonts
    if (is.null(width_row_names)) width_row_names <- grid::stringWidth(strs_with_width[1])
    if (is.null(width_columns)) width_columns <- grid::stringWidth(strs_with_width[-1])
  }

  # Widths for row name, cols, forest.
  widths <- grid::unit.c(
    width_row_names + gap_column,
    width_columns + gap_column,
    width_forest
  )

  n_lines_per_row <- apply(
    X = mat_form$strings,
    MARGIN = 1,
    FUN = function(row) {
      tmp <- vapply(
        gregexpr("\n", row, fixed = TRUE),
        attr, numeric(1),
        "match.length"
      ) + 1
      max(c(tmp, 1))
    }
  )

  i_header <- seq_len(nr_h)

  height_body_rows <- grid::unit(n_lines_per_row[-i_header] * 1.2, "lines")
  height_header_rows <- grid::unit(n_lines_per_row[i_header] * 1.2, "lines")

  height_body <- grid::unit(sum(n_lines_per_row[-i_header]) * 1.2, "lines")
  height_header <- grid::unit(sum(n_lines_per_row[i_header]) * 1.2, "lines")

  nc_g <- nc + 2 # number of columns incl. row names and forest

  vp_tbl <- grid::vpTree(
    parent = grid::viewport(
      name = "vp_table_layout",
      layout = grid::grid.layout(
        nrow = 3, ncol = 1,
        heights = grid::unit.c(height_header, gap_header, height_body)
      )
    ),
    children = grid::vpList(
      vp_forest_table_part(nr_h, nc_g, 1, 1, widths, height_header_rows, "vp_header"),
      vp_forest_table_part(nr, nc_g, 3, 1, widths, height_body_rows, "vp_body"),
      grid::viewport(name = "vp_spacer", layout.pos.row = 2, layout.pos.col = 1)
    )
  )
  vp_tbl
}

#' Viewport Forest Plot: Table Part
#'
#' Prepares a viewport for the table included in the forest plot.
#'
#' @noRd
vp_forest_table_part <- function(nrow,
                                 ncol,
                                 l_row,
                                 l_col,
                                 widths,
                                 heights,
                                 name) {
  grid::vpTree(
    grid::viewport(
      name = name,
      layout.pos.row = l_row,
      layout.pos.col = l_col,
      layout = grid::grid.layout(nrow = nrow, ncol = ncol, widths = widths, heights = heights)
    ),
    children = grid::vpList(
      do.call(
        grid::vpList,
        lapply(
          seq_len(nrow), function(i) {
            grid::viewport(layout.pos.row = i, layout.pos.col = 1, name = paste0("rowname-", i))
          }
        )
      ),
      do.call(
        grid::vpList,
        apply(
          expand.grid(seq_len(nrow), seq_len(ncol - 2)),
          1,
          function(x) {
            i <- x[1]
            j <- x[2]
            grid::viewport(layout.pos.row = i, layout.pos.col = j + 1, name = paste0("cell-", i, "-", j))
          }
        )
      ),
      do.call(
        grid::vpList,
        lapply(
          seq_len(nrow),
          function(i) {
            grid::viewport(layout.pos.row = i, layout.pos.col = ncol, name = paste0("forest-", i))
          }
        )
      )
    )
  )
}

#' Forest Rendering
#'
#' Renders the forest grob.
#'
#' @noRd
grid.forest <- function(...) { # nolint
  grid::grid.draw(forest_grob(...)) # nolint
}

#' Combine Factor Levels
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Combine specified old factor Levels in a single new level.
#'
#' @param x factor
#' @param levels level names to be combined
#' @param new_level name of new level
#'
#' @return a factor
#'
#' @export
#'
#' @examples
#' x <- factor(letters[1:5], levels = letters[5:1])
#' combine_levels(x, levels = c("a", "b"))
#'
#' combine_levels(x, c("e", "b"))
combine_levels <- function(x, levels, new_level = paste(levels, collapse = "/")) {
  checkmate::assert_factor(x)
  checkmate::assert_subset(levels, levels(x))

  lvls <- levels(x)

  lvls[lvls %in% levels] <- new_level

  levels(x) <- lvls

  x
}

#' Conversion of a Vector to a Factor
#'
#' Converts `x` to a factor and keeps its attributes. Warns appropriately such that the user
#' can decide whether they prefer converting to factor manually (e.g. for full control of
#' factor levels).
#'
#' @param x (`atomic`)\cr object to convert.
#' @param x_name (`string`)\cr name of `x`.
#' @param na_level (`string`)\cr the explicit missing level which should be used when
#'   converting a character vector.
#' @param verbose defaults to `TRUE`. It prints out warnings and messages.
#'
#' @return The factor with same attributes (except class) as `x`. Does not do any modifications
#'   if `x` is already a factor.
#'
#' @examples
#' # Internal function - as_factor_keep_attributes
#' \dontrun{
#' as_factor_keep_attributes(formatters::with_label(c(1, 1, 2, 3), "id"), verbose = FALSE)
#' as_factor_keep_attributes(c("a", "b", ""), "id", verbose = FALSE)
#' }
#'
#' @keywords internal
as_factor_keep_attributes <- function(x,
                                      x_name = deparse(substitute(x)),
                                      na_level = "<Missing>",
                                      verbose = TRUE) {
  checkmate::assert_atomic(x)
  checkmate::assert_string(x_name)
  checkmate::assert_string(na_level)
  checkmate::assert_flag(verbose)
  if (is.factor(x)) {
    return(x)
  }
  x_class <- class(x)[1]
  if (verbose) {
    warning(paste(
      "automatically converting", x_class, "variable", x_name,
      "to factor, better manually convert to factor to avoid failures"
    ))
  }
  if (identical(length(x), 0L)) {
    warning(paste(
      x_name, "has length 0, this can lead to tabulation failures, better convert to factor"
    ))
  }
  if (is.character(x)) {
    x_no_na <- explicit_na(sas_na(x), label = na_level)
    if (any(na_level %in% x_no_na)) {
      do.call(
        structure,
        c(
          list(.Data = forcats::fct_relevel(x_no_na, na_level, after = Inf)),
          attributes(x)
        )
      )
    } else {
      do.call(structure, c(list(.Data = as.factor(x)), attributes(x)))
    }
  } else {
    do.call(structure, c(list(.Data = as.factor(x)), attributes(x)))
  }
}

#' Labels for Bins in Percent
#'
#' This creates labels for quantile based bins in percent. This assumes the right-closed
#' intervals as produced by [cut_quantile_bins()].
#'
#' @param probs (`proportion` vector)\cr the probabilities identifying the quantiles.
#'   This is a sorted vector of unique `proportion` values, i.e. between 0 and 1, where
#'   the boundaries 0 and 1 must not be included.
#' @param digits (`integer`)\cr number of decimal places to round the percent numbers.
#'
#' @return Character vector with labels in the format `[0%,20%]`, `(20%,50%]`, etc.
#'
#' @examples
#' # Internal function - bins_percent_labels
#' \dontrun{
#' # Just pass the internal probability bounds, then 0 and 100% will be added automatically.
#' bins_percent_labels(c(0.2, 0.5))
#'
#' # Determine how to round.
#' bins_percent_labels(0.35224, digits = 1)
#'
#' # Passing an empty vector just gives a single bin 0-100%.
#' bins_percent_labels(c(0, 1))
#' }
#'
#' @keywords internal
bins_percent_labels <- function(probs,
                                digits = 0) {
  if (isFALSE(0 %in% probs)) probs <- c(0, probs)
  if (isFALSE(1 %in% probs)) probs <- c(probs, 1)
  checkmate::assert_numeric(probs, lower = 0, upper = 1, unique = TRUE, sorted = TRUE)
  percent <- round(probs * 100, digits = digits)
  left <- paste0(utils::head(percent, -1), "%")
  right <- paste0(utils::tail(percent, -1), "%")
  without_left_bracket <- paste0(left, ",", right, "]")
  with_left_bracket <- paste0("[", utils::head(without_left_bracket, 1))
  if (length(without_left_bracket) > 1) {
    with_left_bracket <- c(
      with_left_bracket,
      paste0("(", utils::tail(without_left_bracket, -1))
    )
  }
  with_left_bracket
}

#' Cutting Numeric Vector into Empirical Quantile Bins
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This cuts a numeric vector into sample quantile bins. Note that the intervals are closed on
#' the right side. That is, the first bin is the interval `[-Inf, q1]` where `q1` is
#' the first quantile, the second bin is then `(q1, q2]`, etc., and the last bin
#' is `(qn, +Inf]` where `qn` is the last quantile.
#'
#' @inheritParams bins_percent_labels
#' @param x (`numeric`)\cr the continuous variable values which should be cut into
#'   quantile bins. This may contain `NA` values, which are then
#'   not used for the quantile calculations, but included in the return vector.
#' @param labels (`character`)\cr the unique labels for the quantile bins. When there are `n`
#'   probabilities in `probs`, then this must be `n + 1` long.
#' @param type (`integer`)\cr type of quantiles to use, see [stats::quantile()] for details.
#' @param ordered (`flag`)\cr should the result be an ordered factor.
#'
#' @return The factor variable with the appropriately labeled bins as levels.
#' @export
#'
#' @examples
#' # Default is to cut into quartile bins.
#' cut_quantile_bins(cars$speed)
#'
#' # Use custom quantiles.
#' cut_quantile_bins(cars$speed, probs = c(0.1, 0.2, 0.6, 0.88))
#'
#' # Use custom labels.
#' cut_quantile_bins(cars$speed, labels = paste0("Q", 1:4))
#'
#' # NAs are preserved in result factor.
#' ozone_binned <- cut_quantile_bins(airquality$Ozone)
#' which(is.na(ozone_binned))
#' # So you might want to make these explicit.
#' explicit_na(ozone_binned)
cut_quantile_bins <- function(x,
                              probs = c(0.25, 0.5, 0.75),
                              labels = NULL,
                              type = 7,
                              ordered = TRUE) {
  checkmate::assert_flag(ordered)
  checkmate::assert_numeric(x)
  if (isFALSE(0 %in% probs)) probs <- c(0, probs)
  if (isFALSE(1 %in% probs)) probs <- c(probs, 1)
  checkmate::assert_numeric(probs, lower = 0, upper = 1, unique = TRUE, sorted = TRUE)
  if (is.null(labels)) labels <- bins_percent_labels(probs)
  checkmate::assert_character(labels, len = length(probs) - 1, any.missing = FALSE, unique = TRUE)

  if (all(is.na(x))) {
    # Early return if there are only NAs in input.
    return(factor(x, ordered = ordered, levels = labels))
  }


  quantiles <- stats::quantile(
    x,
    probs = probs,
    type = type,
    na.rm = TRUE
  )

  checkmate::assert_numeric(quantiles, unique = TRUE)

  cut(
    x,
    breaks = quantiles,
    labels = labels,
    ordered_result = ordered,
    include.lowest = TRUE,
    right = TRUE
  )
}

#' Discard Certain Levels from a Factor
#'
#' This discards the observations as well as the levels specified from a factor.
#'
#' @param x (`factor`)\cr the original factor.
#' @param discard (`character`)\cr which levels to discard.
#'
#' @return The modified factor with observations as well as levels from `discard` dropped.
#' @export
#'
#' @examples
#' fct_discard(factor(c("a", "b", "c")), "c")
fct_discard <- function(x, discard) {
  checkmate::assert_factor(x)
  checkmate::assert_character(discard, any.missing = FALSE)
  new_obs <- x[!(x %in% discard)]
  new_levels <- setdiff(levels(x), discard)
  factor(new_obs, levels = new_levels)
}

#' Insertion of Explicit Missings in a Factor
#'
#' This inserts explicit missings in a factor based on a condition. Note that also additional
#' existing `NA` values will be explicitly converted to given `na_level`.
#'
#' @param x (`factor`)\cr the original factor.
#' @param condition (`logical`)\cr where to insert missings.
#' @param na_level (`string`)\cr which level to use for missings.
#'
#' @return The modified factor with inserted and existing `NA` converted to `na_level`.
#' @seealso [forcats::fct_na_value_to_level()] which is used internally.
#'
#' @examples
#' fct_explicit_na_if(factor(c("a", "b", NA)), c(TRUE, FALSE, FALSE))
#'
#' @export
fct_explicit_na_if <- function(x, condition, na_level = "<Missing>") {
  checkmate::assert_factor(x, len = length(condition))
  checkmate::assert_logical(condition)
  x[condition] <- NA
  x <- forcats::fct_na_value_to_level(x, level = na_level)
  forcats::fct_drop(x, only = na_level)
}

#' Collapsing of Factor Levels and Keeping Only Those New Group Levels
#'
#' This collapses levels and only keeps those new group levels, in the order provided.
#' The returned factor has levels in the order given, with the possible missing level last (this will
#' only be included if there are missings). Note that any existing `NA` in the input vector will
#' not be replaced by the missing level. If needed [explicit_na()] can be called separately on the result.
#'
#' @param .f (`factor` or `character`)\cr original vector.
#' @param ... (named `character` vectors)\cr levels in each vector provided will be collapsed into
#'   the new level given by the respective name.
#' @param .na_level (`string`)\cr which level to use for other levels, which should be missing in the
#'   new factor. Note that this level must not be contained in the new levels specified in `...`.
#'
#' @return The modified factor with collapsed levels. Values and levels which are not included
#'   in the given character vectors input will be set to the missing level.
#' @seealso [forcats::fct_collapse()], [forcats::fct_relevel()] which are used internally.
#'
#' @examples
#' fct_collapse_only(factor(c("a", "b", "c", "d")), TRT = "b", CTRL = c("c", "d"))
#'
#' @export
fct_collapse_only <- function(.f, ..., .na_level = "<Missing>") {
  new_lvls <- names(list(...))
  if (checkmate::test_subset(.na_level, new_lvls)) {
    stop(paste0(".na_level currently set to '", .na_level, "' must not be contained in the new levels"))
  }
  x <- forcats::fct_collapse(.f, ..., other_level = .na_level)
  do.call(forcats::fct_relevel, args = c(list(.f = x), as.list(new_lvls)))
}

#' Add Titles, Footnotes, Page Number, and a Bounding Box to a Grid Grob
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This function is useful to label grid grobs (also \code{ggplot2}, and \code{lattice} plots)
#' with title, footnote, and page numbers.
#'
#' @inheritParams grid::grob
#' @param grob a grid grob object, optionally \code{NULL} if only a \code{grob} with
#'   the decoration should be shown.
#' @param titles vector of character strings. Vector elements are separated by a
#'   newline and strings are wrapped according to the page with.
#' @param footnotes vector of character string. Same rules as for \code{titles}.
#' @param page string with page numeration, if \code{NULL} then no page number is displayed.
#' @param width_titles unit object
#' @param width_footnotes unit object
#' @param border boolean, whether a a border should be drawn around the plot or
#'   not.
#' @param margins unit object of length 4
#' @param padding  unit object of length 4
#' @param outer_margins  unit object of length 4
#' @param gp_titles a \code{gpar} object
#' @param gp_footnotes a \code{gpar} object
#'
#' @details
#' The titles and footnotes will be ragged, i.e. each title will be wrapped
#' individually.
#'
#' \if{html}{
#' The layout can be illustrated as follows:
#'
#' \figure{decorate_grob.png}{options: alt="decorate_grob layout"}
#' }
#'
#' @return a grid grob (\code{gTree})
#'
#' @export
#' @template author_waddella
#'
#' @examples
#' library(grid)
#'
#' titles <- c(
#'   "Edgar Anderson's Iris Data",
#'   paste(
#'     "This famous (Fisher's or Anderson's) iris data set gives the measurements",
#'     "in centimeters of the variables sepal length and width and petal length",
#'     "and width, respectively, for 50 flowers from each of 3 species of iris."
#'   )
#' )
#'
#' footnotes <- c(
#'   "The species are Iris setosa, versicolor, and virginica.",
#'   paste(
#'     "iris is a data frame with 150 cases (rows) and 5 variables (columns) named",
#'     "Sepal.Length, Sepal.Width, Petal.Length, Petal.Width, and Species."
#'   )
#' )
#'
#' ## empty plot
#' grid.newpage()
#'
#' grid.draw(
#'   decorate_grob(
#'     NULL,
#'     titles = titles,
#'     footnotes = footnotes,
#'     page = "Page 4 of 10"
#'   )
#' )
#'
#' # grid
#' p <- gTree(
#'   children = gList(
#'     rectGrob(),
#'     xaxisGrob(),
#'     yaxisGrob(),
#'     textGrob("Sepal.Length", y = unit(-4, "lines")),
#'     textGrob("Petal.Length", x = unit(-3.5, "lines"), rot = 90),
#'     pointsGrob(iris$Sepal.Length, iris$Petal.Length, gp = gpar(col = iris$Species), pch = 16)
#'   ),
#'   vp = vpStack(plotViewport(), dataViewport(xData = iris$Sepal.Length, yData = iris$Petal.Length))
#' )
#' grid.newpage()
#' grid.draw(p)
#'
#' grid.newpage()
#' grid.draw(
#'   decorate_grob(
#'     grob = p,
#'     titles = titles,
#'     footnotes = footnotes,
#'     page = "Page 6 of 129"
#'   )
#' )
#'
#' ## with \code{ggplot2}
#' library(ggplot2)
#'
#' p_gg <- ggplot2::ggplot(iris, aes(Sepal.Length, Sepal.Width, col = Species)) +
#'   ggplot2::geom_point()
#' p_gg
#' p <- ggplotGrob(p_gg)
#' grid.newpage()
#' grid.draw(
#'   decorate_grob(
#'     grob = p,
#'     titles = titles,
#'     footnotes = footnotes,
#'     page = "Page 6 of 129"
#'   )
#' )
#'
#' ## with \code{lattice}
#' library(lattice)
#'
#' xyplot(Sepal.Length ~ Petal.Length, data = iris, col = iris$Species)
#' p <- grid.grab()
#' grid.newpage()
#' grid.draw(
#'   decorate_grob(
#'     grob = p,
#'     titles = titles,
#'     footnotes = footnotes,
#'     page = "Page 6 of 129"
#'   )
#' )
#'
#' # with \code{gridExtra} - no borders
#' library(gridExtra)
#' grid.newpage()
#' grid.draw(
#'   decorate_grob(
#'     tableGrob(
#'       head(mtcars)
#'     ),
#'     titles = "title",
#'     footnotes = "footnote",
#'     border = FALSE
#'   )
#' )
decorate_grob <- function(grob,
                          titles,
                          footnotes,
                          page = "",
                          width_titles = grid::unit(1, "npc"),
                          width_footnotes = grid::unit(1, "npc") - grid::stringWidth(page),
                          border = TRUE,
                          margins = grid::unit(c(1, 0, 1, 0), "lines"),
                          padding = grid::unit(rep(1, 4), "lines"),
                          outer_margins = grid::unit(c(2, 1.5, 3, 1.5), "cm"),
                          gp_titles = grid::gpar(),
                          gp_footnotes = grid::gpar(fontsize = 8),
                          name = NULL,
                          gp = grid::gpar(),
                          vp = NULL) {
  st_titles <- split_text_grob(
    titles,
    x = 0, y = 1,
    just = c("left", "top"),
    width = width_titles,
    vp = grid::viewport(layout.pos.row = 1, layout.pos.col = 1),
    gp = gp_titles
  )

  st_footnotes <- split_text_grob(
    footnotes,
    x = 0, y = 1,
    just = c("left", "top"),
    width = width_footnotes,
    vp = grid::viewport(layout.pos.row = 3, layout.pos.col = 1),
    gp = gp_footnotes
  )

  grid::gTree(
    grob = grob,
    titles = titles,
    footnotes = footnotes,
    page = page,
    width_titles = width_titles,
    width_footnotes = width_footnotes,
    border = border,
    margins = margins,
    padding = padding,
    outer_margins = outer_margins,
    gp_titles = gp_titles,
    gp_footnotes = gp_footnotes,
    children = grid::gList(
      grid::gTree(
        children = grid::gList(
          st_titles,
          grid::gTree(
            children = grid::gList(
              if (border) grid::rectGrob(),
              grid::gTree(
                children = grid::gList(
                  grob
                ),
                vp = grid::plotViewport(margins = padding)
              )
            ),
            vp = grid::vpStack(
              grid::viewport(layout.pos.row = 2, layout.pos.col = 1),
              grid::plotViewport(margins = margins)
            )
          ),
          st_footnotes,
          grid::textGrob(
            page,
            x = 1, y = 0,
            just = c("right", "bottom"),
            vp = grid::viewport(layout.pos.row = 3, layout.pos.col = 1),
            gp = gp_footnotes
          )
        ),
        childrenvp = NULL,
        name = "titles_grob_footnotes",
        vp = grid::vpStack(
          grid::plotViewport(margins = outer_margins),
          grid::viewport(
            layout = grid::grid.layout(
              nrow = 3, ncol = 1,
              heights = grid::unit.c(
                grid::grobHeight(st_titles),
                grid::unit(1, "null"),
                grid::grobHeight(st_footnotes)
              )
            )
          )
        )
      )
    ),
    name = name,
    gp = gp,
    vp = vp,
    cl = "decoratedGrob"
  )
}

#' @importFrom grid validDetails
#' @export
validDetails.decoratedGrob <- function(x) { # nolint

  checkmate::assert_character(x$titles)
  checkmate::assert_character(x$footnotes)

  if (!is.null(x$grob)) {
    checkmate::assert_true(grid::is.grob(x$grob))
  }
  if (length(x$page) == 1) {
    checkmate::assert_character(x$page)
  }
  if (!grid::is.unit(x$outer_margins)) {
    checkmate::assert_vector(x$outer_margins, len = 4)
  }
  if (!grid::is.unit(x$margins)) {
    checkmate::assert_vector(x$margins, len = 4)
  }
  if (!grid::is.unit(x$padding)) {
    checkmate::assert_vector(x$padding, len = 4)
  }

  x
}

#' @importFrom grid widthDetails
#' @export
widthDetails.decoratedGrob <- function(x) { # nolint
  grid::unit(1, "null")
}

#' @importFrom grid heightDetails
#' @export
heightDetails.decoratedGrob <- function(x) { # nolint
  grid::unit(1, "null")
}

# Adapted from Paul Murell R Graphics 2nd Edition
# https://www.stat.auckland.ac.nz/~paul/RG2e/interactgrid-splittext.R
split_string <- function(text, width) {
  availwidth <- grid::convertWidth(width, "in", valueOnly = TRUE)
  textwidth <- grid::convertWidth(grid::stringWidth(text), "in", valueOnly = TRUE)
  strings <- strsplit(text, " ")[[1]]

  if (textwidth <= availwidth || length(strings) == 1) {
    text
  } else {
    gapwidth <- grid::stringWidth(" ")
    newstring <- strings[1]
    linewidth <- grid::stringWidth(newstring)

    for (i in 2:length(strings)) {
      str_width <- grid::stringWidth(strings[i])
      if (grid::convertWidth(linewidth + gapwidth + str_width, "in", valueOnly = TRUE) < availwidth) {
        sep <- " "
        linewidth <- linewidth + gapwidth + str_width
      } else {
        sep <- "\n"
        linewidth <- str_width
      }
      newstring <- paste(newstring, strings[i], sep = sep)
    }
    newstring
  }
}

#' Split Text According To Available Text Width
#'
#' Dynamically wrap text.
#'
#' @inheritParams grid::grid.text
#' @param text character string
#' @param width a unit object specifying max width of text
#'
#' @details
#' This code is taken from R Graphics by \code{Paul Murell}, 2nd edition
#'
#' @examples
#' # Internal function - split_text_grob
#' \dontrun{
#' sg <- split_text_grob(text = paste(
#'   "Lorem ipsum dolor sit amet, consectetur adipiscing elit. Vestibulum vitae",
#'   "dapibus dolor, ac mattis erat. Nunc metus lectus, imperdiet ut enim eu,",
#'   "commodo scelerisque urna. Vestibulum facilisis metus vel nibh tempor, sed",
#'   "elementum sem tempus. Morbi quis arcu condimentum, maximus lorem id,",
#'   "tristique ante. Nullam a nunc dui. Fusce quis lacus nec ante dignissim",
#'   "faucibus nec vitae tellus. Suspendisse mollis et sapien eu ornare. Vestibulum",
#'   "placerat neque nec justo efficitur, ornare varius nulla imperdiet. Nunc justo",
#'   "sapien, vestibulum eget efficitur eget, porttitor id ante. Nulla tempor",
#'   "luctus massa id elementum. Praesent dictum, neque vitae vestibulum malesuada,",
#'   "nunc nisi blandit lacus, sit amet tristique odio dui sit amet velit."
#' ))
#'
#' library(grid)
#' grobHeight(sg)
#'
#' grid.newpage()
#' pushViewport(plotViewport())
#' grid.rect()
#' grid.draw(sg)
#'
#' grid.rect(
#'   height = grobHeight(sg), width = unit(1, "cm"), gp = gpar(fill = "red")
#' )
#'
#' # stack split_text_grob
#' grid.newpage()
#' pushViewport(plotViewport())
#' grid.rect()
#' grid.draw(split_text_grob(
#'   c("Hello, this is a test", "and yet another test"),
#'   just = c("left", "top"), x = 0, y = 1
#' ))
#' }
#'
#' @keywords internal
split_text_grob <- function(text,
                            x = grid::unit(0.5, "npc"),
                            y = grid::unit(0.5, "npc"),
                            width = grid::unit(1, "npc"),
                            just = "centre",
                            hjust = NULL,
                            vjust = NULL,
                            default.units = "npc", # nolint
                            name = NULL,
                            gp = grid::gpar(),
                            vp = NULL) {
  if (!grid::is.unit(x)) {
    x <- grid::unit(x, default.units)
  }
  if (!grid::is.unit(y)) {
    y <- grid::unit(y, default.units)
  }

  checkmate::assert_true(grid::is.unit(width))
  checkmate::assert_vector(width, len = 1)

  ## if it is a fixed unit then we do not need to recalculate when viewport resized
  if (!inherits(width, "unit.arithmetic") &&
    !is.null(attr(width, "unit")) &&
    attr(width, "unit") %in% c("cm", "inches", "mm", "points", "picas", "bigpts", "dida", "cicero", "scaledpts")) {
    attr(text, "fixed_text") <- paste(vapply(text, split_string, character(1), width = width), collapse = "\n")
  }

  grid::grob(
    text = text,
    x = x, y = y,
    width = width,
    just = just,
    hjust = hjust,
    vjust = vjust,
    rot = 0,
    check.overlap = FALSE,
    name = name,
    gp = gp,
    vp = vp,
    cl = "dynamicSplitText"
  )
}

#' @importFrom grid validDetails
#' @export
validDetails.dynamicSplitText <- function(x) { # nolint
  checkmate::assert_character(x$text)
  checkmate::assert_true(grid::is.unit(x$width))
  checkmate::assert_vector(x$width, len = 1)
  x
}

#' @importFrom grid heightDetails
#' @export
heightDetails.dynamicSplitText <- function(x) { # nolint
  txt <- if (!is.null(attr(x$text, "fixed_text"))) {
    attr(x$text, "fixed_text")
  } else {
    paste(vapply(x$text, split_string, character(1), width = x$width), collapse = "\n")
  }
  grid::stringHeight(txt)
}

#' @importFrom grid widthDetails
#' @export
widthDetails.dynamicSplitText <- function(x) { # nolint
  x$width
}

#' @importFrom grid drawDetails
#' @export
drawDetails.dynamicSplitText <- function(x, recording) { # nolint
  txt <- if (!is.null(attr(x$text, "fixed_text"))) {
    attr(x$text, "fixed_text")
  } else {
    paste(vapply(x$text, split_string, character(1), width = x$width), collapse = "\n")
  }

  x$width <- NULL
  x$label <- txt
  x$text <- NULL
  class(x) <- c("text", class(x)[-1])

  grid::grid.draw(x)
}

#' Update Page Number
#'
#' Automatically updates page number.
#'
#' @param npages number of pages in total
#' @param ... passed on to \code{\link{decorate_grob}}
#'
#' @return closure that increments the page number
#'
#' @keywords internal
#' @template author_waddella
#'
#' @examples
#' # Internal function - decorate_grob_factory
#' \dontrun{
#' pf <- decorate_grob_factory(
#'   titles = "This is a test\nHello World",
#'   footnotes = "Here belong the footnotess",
#'   npages = 3
#' )
#'
#' library(grid)
#' draw_grob(pf(NULL))
#' draw_grob(pf(NULL))
#' draw_grob(pf(NULL))
#' }
decorate_grob_factory <- function(npages, ...) {
  current_page <- 0
  function(grob) {
    current_page <<- current_page + 1
    if (current_page > npages) {
      stop(paste("current page is", current_page, "but max.", npages, "specified."))
    }
    decorate_grob(grob = grob, page = paste("Page", current_page, "of", npages), ...)
  }
}

#' Decorate Set of `grobs` and Add Page Numbering
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Note that this uses the `decorate_grob_factory` function.
#'
#' @param grobs a list of grid grobs
#' @param ... arguments passed on to \code{\link{decorate_grob}}
#'
#' @template author_waddella
#'
#' @examples
#' library(ggplot2)
#' library(grid)
#' g <- with(data = iris, {
#'   list(
#'     ggplot2::ggplotGrob(
#'       ggplot2::ggplot(mapping = aes(Sepal.Length, Sepal.Width, col = Species)) +
#'         ggplot2::geom_point()
#'     ),
#'     ggplot2::ggplotGrob(
#'       ggplot2::ggplot(mapping = aes(Sepal.Length, Petal.Length, col = Species)) +
#'         ggplot2::geom_point()
#'     ),
#'     ggplot2::ggplotGrob(
#'       ggplot2::ggplot(mapping = aes(Sepal.Length, Petal.Width, col = Species)) +
#'         ggplot2::geom_point()
#'     ),
#'     ggplot2::ggplotGrob(
#'       ggplot2::ggplot(mapping = aes(Sepal.Width, Petal.Length, col = Species)) +
#'         ggplot2::geom_point()
#'     ),
#'     ggplot2::ggplotGrob(
#'       ggplot2::ggplot(mapping = aes(Sepal.Width, Petal.Width, col = Species)) +
#'         ggplot2::geom_point()
#'     ),
#'     ggplot2::ggplotGrob(
#'       ggplot2::ggplot(mapping = aes(Petal.Length, Petal.Width, col = Species)) +
#'         ggplot2::geom_point()
#'     )
#'   )
#' })
#' lg <- decorate_grob_set(grobs = g, titles = "Hello\nOne\nTwo\nThree", footnotes = "")
#'
#' draw_grob(lg[[1]])
#' draw_grob(lg[[2]])
#' draw_grob(lg[[6]])
#'
#' @export
decorate_grob_set <- function(grobs, ...) {
  n <- length(grobs)
  lgf <- decorate_grob_factory(npages = n, ...)
  lapply(grobs, lgf)
}

#' Patient Counts with the Most Extreme Post-baseline Toxicity Grade per Direction of Abnormality
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Primary analysis variable `.var` indicates the toxicity grade (factor), and additional
#' analysis variables are `id` (character or factor), `param` (`factor`) and `grade_dir` (`factor`).
#' The pre-processing steps are crucial when using this function.
#' For a certain direction (e.g. high or low) this function counts
#' patients in the denominator as number of patients with at least one valid measurement during treatment,
#' and patients in the numerator as follows:
#'   * `1` to `4`: Numerator is number of patients with worst grades 1-4 respectively;
#'   * `Any`: Numerator is number of patients with at least one abnormality, which means grade is different from 0.
#'
#' @details
#' The pre-processing steps are crucial when using this function. From the standard
#' lab grade variable `ATOXGR`, derive the following two variables:
#'   * A grade direction variable (e.g. `GRADE_DIR`) is required in order to obtain
#'     the correct denominators when building the layout as it is used to define row splitting.
#'   * A toxicity grade variable (e.g. `GRADE_ANL`) where all negative values from
#'     `ATOXGR` are replaced by their absolute values.
#'   * Prior to tabulation, `df` must filtered to include only post-baseline records with worst grade flags.
#'
#' @inheritParams argument_convention
#'
#' @name abnormal_by_worst_grade
NULL

#' @describeIn abnormal_by_worst_grade Statistics function which counts patients with worst grade,
#'   consisting of counts and percentages of patients with worst grade
#'   `1` to `4`, and `Any` non-zero grade.
#'
#' @return [s_count_abnormal_by_worst_grade()] the single statistic `count_fraction` with grade 1 to 4
#'   and "Any" results.
#'
#' @examples
#' library(dplyr)
#' library(forcats)
#' adlb <- tern_ex_adlb
#'
#' # Data is modified in order to have some parameters with grades only in one direction
#' # and simulate the real data.
#' adlb$ATOXGR[adlb$PARAMCD == "ALT" & adlb$ATOXGR %in% c("1", "2", "3", "4")] <- "-1"
#' adlb$ANRIND[adlb$PARAMCD == "ALT" & adlb$ANRIND == "HIGH"] <- "LOW"
#' adlb$WGRHIFL[adlb$PARAMCD == "ALT"] <- ""
#'
#' adlb$ATOXGR[adlb$PARAMCD == "IGA" & adlb$ATOXGR %in% c("-1", "-2", "-3", "-4")] <- "1"
#' adlb$ANRIND[adlb$PARAMCD == "IGA" & adlb$ANRIND == "LOW"] <- "HIGH"
#' adlb$WGRLOFL[adlb$PARAMCD == "IGA"] <- ""
#'
#' # Here starts the real pre-processing.
#' adlb_f <- adlb %>%
#'   filter(!AVISIT %in% c("SCREENING", "BASELINE")) %>%
#'   mutate(
#'     GRADE_DIR = factor(
#'       case_when(
#'         ATOXGR %in% c("-1", "-2", "-3", "-4") ~ "LOW",
#'         ATOXGR == "0" ~ "ZERO",
#'         ATOXGR %in% c("1", "2", "3", "4") ~ "HIGH"
#'       ),
#'       levels = c("LOW", "ZERO", "HIGH")
#'     ),
#'     GRADE_ANL = fct_relevel(
#'       fct_recode(ATOXGR, `1` = "-1", `2` = "-2", `3` = "-3", `4` = "-4"),
#'       c("0", "1", "2", "3", "4")
#'     )
#'   ) %>%
#'   filter(WGRLOFL == "Y" | WGRHIFL == "Y") %>%
#'   droplevels()
#'
#' adlb_f_alt <- adlb_f %>%
#'   filter(PARAMCD == "ALT") %>%
#'   droplevels()
#' full_parent_df <- list(adlb_f_alt, "not_needed")
#' cur_col_subset <- list(rep(TRUE, nrow(adlb_f_alt)), "not_needed")
#'
#' # This mimics a split structure on PARAM and GRADE_DIR for a total column
#' spl_context <- data.frame(
#'   split = c("PARAM", "GRADE_DIR"),
#'   full_parent_df = I(full_parent_df),
#'   cur_col_subset = I(cur_col_subset)
#' )
#'
#' # Internal function - s_count_abnormal_by_worst_grade
#' \dontrun{
#' s_count_abnormal_by_worst_grade(
#'   df = adlb_f_alt,
#'   .spl_context = spl_context,
#'   .var = "GRADE_ANL"
#' )
#' }
#'
#' @keywords internal
s_count_abnormal_by_worst_grade <- function(df, # nolint
                                            .var = "GRADE_ANL",
                                            .spl_context,
                                            variables = list(
                                              id = "USUBJID",
                                              param = "PARAM",
                                              grade_dir = "GRADE_DIR"
                                            )) {
  checkmate::assert_string(.var)
  assert_valid_factor(df[[.var]])
  assert_valid_factor(df[[variables$param]])
  assert_valid_factor(df[[variables$grade_dir]])
  assert_df_with_variables(df, c(a = .var, variables))
  checkmate::assert_multi_class(df[[variables$id]], classes = c("factor", "character"))

  # To verify that the `split_rows_by` are performed with correct variables.
  checkmate::assert_subset(c(variables[["param"]], variables[["grade_dir"]]), .spl_context$split)
  first_row <- .spl_context[.spl_context$split == variables[["param"]], ] # nolint
  x_lvls <- c(setdiff(levels(df[[.var]]), "0"), "Any")
  result <- split(numeric(0), factor(x_lvls))

  subj <- first_row$full_parent_df[[1]][[variables[["id"]]]]
  subj_cur_col <- subj[first_row$cur_col_subset[[1]]]
  # Some subjects may have a record for high and low directions but
  # should be counted only once.
  denom <- length(unique(subj_cur_col))

  for (lvl in x_lvls) {
    if (lvl != "Any") {
      df_lvl <- df[df[[.var]] == lvl, ]
    } else {
      df_lvl <- df[df[[.var]] != 0, ]
    }
    num <- length(unique(df_lvl[["USUBJID"]]))
    fraction <- ifelse(denom == 0, 0, num / denom)
    result[[lvl]] <- formatters::with_label(c(count = num, fraction = fraction), lvl)
  }

  result <- list(count_fraction = result)
  result
}

#' @describeIn abnormal_by_worst_grade Formatted Analysis function which can be further customized by calling
#'   [rtables::make_afun()] on it. It is used as `afun` in [rtables::analyze()].
#'
#' @return [a_count_abnormal_by_worst_grade()] returns the corresponding list with formatted [rtables::CellValue()].
#'
#' @examples
#' # Internal function - a_count_abnormal_by_worst_grade
#' \dontrun{
#' # Use the Formatted Analysis function for `analyze()`. We need to ungroup `count_fraction` first
#' # so that the `rtables` formatting function `format_count_fraction()` can be applied correctly.
#' afun <- make_afun(a_count_abnormal_by_worst_grade, .ungroup_stats = "count_fraction")
#' afun(df = adlb_f_alt, .spl_context = spl_context)
#' }
#'
#' @keywords internal
a_count_abnormal_by_worst_grade <- make_afun( # nolint
  s_count_abnormal_by_worst_grade,
  .formats = c(count_fraction = format_count_fraction)
)

#' @describeIn abnormal_by_worst_grade Layout creating function which can be used for creating tables,
#'    which can take statistics function arguments and additional format arguments (see below).
#'
#' @examples
#' # Map excludes records without abnormal grade since they should not be displayed
#' # in the table.
#' map <- unique(adlb_f[adlb_f$GRADE_DIR != "ZERO", c("PARAM", "GRADE_DIR", "GRADE_ANL")]) %>%
#'   lapply(as.character) %>%
#'   as.data.frame() %>%
#'   arrange(PARAM, desc(GRADE_DIR), GRADE_ANL)
#'
#' basic_table() %>%
#'   split_cols_by("ARMCD") %>%
#'   split_rows_by("PARAM") %>%
#'   split_rows_by("GRADE_DIR", split_fun = trim_levels_to_map(map)) %>%
#'   count_abnormal_by_worst_grade(
#'     var = "GRADE_ANL",
#'     variables = list(id = "USUBJID", param = "PARAM", grade_dir = "GRADE_DIR")
#'   ) %>%
#'   build_table(df = adlb_f)
#'
#' @export
count_abnormal_by_worst_grade <- function(lyt,
                                          var,
                                          ...,
                                          .stats = NULL,
                                          .formats = NULL,
                                          .labels = NULL,
                                          .indent_mods = NULL) {
  afun <- make_afun(
    a_count_abnormal_by_worst_grade,
    .stats = .stats,
    .formats = .formats,
    .labels = .labels,
    .indent_mods = .indent_mods,
    .ungroup_stats = "count_fraction"
  )
  analyze(
    lyt = lyt,
    vars = var,
    afun = afun,
    extra_args = list(...),
    show_labels = "hidden"
  )
}

#' Odds Ratio Estimation
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Compares bivariate responses between two groups in terms of odds ratios
#' along with a confidence interval.
#'
#' @details This function uses either logistic regression for unstratified
#'   analyses, or conditional logistic regression for stratified analyses.
#'   The Wald confidence interval with the specified confidence level is
#'   calculated. Note that, for stratified analyses, there is currently no
#'   implementation for conditional likelihood confidence intervals,
#'   therefore the likelihood confidence interval as an option is not yet
#'   available. Besides, when `rsp` contains only responders or non-responders,
#'   then the result values will be `NA`, because no odds ratio estimation is
#'   possible.
#' @seealso Relevant helper function [h_odds_ratio()].
#'
#' @name odds_ratio
NULL

#' @describeIn odds_ratio Statistics function which estimates the odds ratio
#'   between a treatment and a control. Note that a `variables` list with `arm` and `strata` names
#'   needs to be passed if a stratified analysis is required.
#' @inheritParams split_cols_by_groups
#' @inheritParams argument_convention
#' @export
#'
#' @examples
#' set.seed(12)
#' dta <- data.frame(
#'   rsp = sample(c(TRUE, FALSE), 100, TRUE),
#'   grp = factor(rep(c("A", "B"), each = 50), levels = c("B", "A")),
#'   strata = factor(sample(c("C", "D"), 100, TRUE))
#' )
#'
#' # Unstratified analysis.
#' s_odds_ratio(
#'   df = subset(dta, grp == "A"),
#'   .var = "rsp",
#'   .ref_group = subset(dta, grp == "B"),
#'   .in_ref_col = FALSE,
#'   .df_row = dta
#' )
#'
#' # Stratified analysis.
#' s_odds_ratio(
#'   df = subset(dta, grp == "A"),
#'   .var = "rsp",
#'   .ref_group = subset(dta, grp == "B"),
#'   .in_ref_col = FALSE,
#'   .df_row = dta,
#'   variables = list(arm = "grp", strata = "strata")
#' )
s_odds_ratio <- function(df,
                         .var,
                         .ref_group,
                         .in_ref_col,
                         .df_row,
                         variables = list(arm = NULL, strata = NULL),
                         conf_level = 0.95,
                         groups_list = NULL) {
  y <- list(or_ci = "", n_tot = "")

  if (!.in_ref_col) {
    assert_proportion_value(conf_level)
    assert_df_with_variables(df, list(rsp = .var))
    assert_df_with_variables(.ref_group, list(rsp = .var))

    if (is.null(variables$strata)) {
      data <- data.frame(
        rsp = c(.ref_group[[.var]], df[[.var]]),
        grp = factor(
          rep(c("ref", "Not-ref"), c(nrow(.ref_group), nrow(df))),
          levels = c("ref", "Not-ref")
        )
      )
      y <- or_glm(data, conf_level = conf_level)
    } else {
      assert_df_with_variables(.df_row, c(list(rsp = .var), variables))

      # The group variable prepared for clogit must be synchronised with combination groups definition.
      if (is.null(groups_list)) {
        ref_grp <- as.character(unique(.ref_group[[variables$arm]]))
        trt_grp <- as.character(unique(df[[variables$arm]]))
        grp <- stats::relevel(factor(.df_row[[variables$arm]]), ref = ref_grp)
      } else {
        # If more than one level in reference col.
        reference <- as.character(unique(.ref_group[[variables$arm]]))
        grp_ref_flag <- vapply(
          X = groups_list,
          FUN.VALUE = TRUE,
          FUN = function(x) all(reference %in% x)
        )
        ref_grp <- names(groups_list)[grp_ref_flag]

        # If more than one level in treatment col.
        treatment <- as.character(unique(df[[variables$arm]]))
        grp_trt_flag <- vapply(
          X = groups_list,
          FUN.VALUE = TRUE,
          FUN = function(x) all(treatment %in% x)
        )
        trt_grp <- names(groups_list)[grp_trt_flag]

        grp <- combine_levels(.df_row[[variables$arm]], levels = reference, new_level = ref_grp)
        grp <- combine_levels(grp, levels = treatment, new_level = trt_grp)
      }

      # The reference level in `grp` must be the same as in the `rtables` column split.
      data <- data.frame(
        rsp = .df_row[[.var]],
        grp = grp,
        strata = interaction(.df_row[variables$strata])
      )
      y_all <- or_clogit(data, conf_level = conf_level)
      checkmate::assert_string(trt_grp)
      checkmate::assert_subset(trt_grp, names(y_all$or_ci))
      y$or_ci <- y_all$or_ci[[trt_grp]]
      y$n_tot <- y_all$n_tot
    }
  }

  y$or_ci <- formatters::with_label(
    x = y$or_ci,
    label = paste0("Odds Ratio (", 100 * conf_level, "% CI)")
  )

  y$n_tot <- formatters::with_label(
    x = y$n_tot,
    label = "Total n"
  )

  y
}

#' @describeIn odds_ratio Formatted Analysis function which can be further customized by calling
#'   [rtables::make_afun()] on it. It is used as `afun` in [rtables::analyze()].
#' @export
#'
#' @examples
#' a_odds_ratio(
#'   df = subset(dta, grp == "A"),
#'   .var = "rsp",
#'   .ref_group = subset(dta, grp == "B"),
#'   .in_ref_col = FALSE,
#'   .df_row = dta
#' )
a_odds_ratio <- make_afun(
  s_odds_ratio,
  .formats = c(or_ci = "xx.xx (xx.xx - xx.xx)"),
  .indent_mods = c(or_ci = 1L)
)

#' @describeIn odds_ratio Layout creating function which can be used for creating
#'   tables, which can take statistics function arguments and additional format
#'   arguments (see below).
#'
#' @inheritParams argument_convention
#' @param ... arguments passed to `s_odds_ratio()`.
#' @export
#'
#' @examples
#' dta <- data.frame(
#'   rsp = sample(c(TRUE, FALSE), 100, TRUE),
#'   grp = factor(rep(c("A", "B"), each = 50))
#' )
#'
#' l <- basic_table() %>%
#'   split_cols_by(var = "grp", ref_group = "B") %>%
#'   estimate_odds_ratio(vars = "rsp")
#'
#' build_table(l, df = dta)
estimate_odds_ratio <- function(lyt,
                                vars,
                                ...,
                                show_labels = "hidden",
                                table_names = vars,
                                .stats = "or_ci",
                                .formats = NULL,
                                .labels = NULL,
                                .indent_mods = NULL) {
  afun <- make_afun(
    a_odds_ratio,
    .stats = .stats,
    .formats = .formats,
    .labels = .labels,
    .indent_mods = .indent_mods
  )

  analyze(
    lyt,
    vars,
    afun = afun,
    extra_args = list(...),
    show_labels = show_labels,
    table_names = table_names
  )
}

#' Helper Functions for Odds Ratio Estimation
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Functions to calculate odds ratios in [estimate_odds_ratio()].
#'
#' @inheritParams argument_convention
#' @param data (`data.frame`)\cr data frame containing at least the variables `rsp` and `grp`, and optionally
#'   `strata` for [or_clogit()].
#'
#' @seealso [odds_ratio]
#'
#' @name h_odds_ratio
NULL

#' @describeIn h_odds_ratio estimates the odds ratio based on [stats::glm()]. Note that there must be
#'   exactly 2 groups in `data` as specified by the `grp` variable.
#'
#' @export
#'
#' @examples
#' # Data with 2 groups.
#' data <- data.frame(
#'   rsp = as.logical(c(1, 1, 0, 1, 0, 0, 1, 1)),
#'   grp = letters[c(1, 1, 1, 2, 2, 2, 1, 2)],
#'   strata = letters[c(1, 2, 1, 2, 2, 2, 1, 2)],
#'   stringsAsFactors = TRUE
#' )
#'
#' # Odds ratio based on glm.
#' or_glm(data, conf_level = 0.95)
or_glm <- function(data, conf_level) {
  checkmate::assert_logical(data$rsp)
  assert_proportion_value(conf_level)
  assert_df_with_variables(data, list(rsp = "rsp", grp = "grp"))
  checkmate::assert_multi_class(data$grp, classes = c("factor", "character"))

  data$grp <- as_factor_keep_attributes(data$grp)
  assert_df_with_factors(data, list(val = "grp"), min.levels = 2, max.levels = 2)
  formula <- stats::as.formula("rsp ~ grp")
  model_fit <- stats::glm(
    formula = formula, data = data,
    family = stats::binomial(link = "logit")
  )

  # Note that here we need to discard the intercept.
  or <- exp(stats::coef(model_fit)[-1])
  or_ci <- exp(
    stats::confint.default(model_fit, level = conf_level)[-1, , drop = FALSE]
  )

  values <- stats::setNames(c(or, or_ci), c("est", "lcl", "ucl"))
  n_tot <- stats::setNames(nrow(model_fit$model), "n_tot")

  list(or_ci = values, n_tot = n_tot)
}

#' @describeIn h_odds_ratio estimates the odds ratio based on [survival::clogit()]. This is done for
#'   the whole data set including all groups, since the results are not the same as when doing
#'   pairwise comparisons between the groups.
#'
#' @export
#'
#' @examples
#' # Data with 3 groups.
#' data <- data.frame(
#'   rsp = as.logical(c(1, 1, 0, 1, 0, 0, 1, 1, 0, 0, 1, 1, 0, 1, 0, 0, 1, 1, 0, 0)),
#'   grp = letters[c(1, 1, 1, 2, 2, 2, 3, 3, 3, 3, 1, 1, 1, 2, 2, 2, 3, 3, 3, 3)],
#'   strata = LETTERS[c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2)],
#'   stringsAsFactors = TRUE
#' )
#'
#' # Odds ratio based on stratified estimation by conditional logistic regression.
#' or_clogit(data, conf_level = 0.95)
or_clogit <- function(data, conf_level) {
  checkmate::assert_logical(data$rsp)
  assert_proportion_value(conf_level)
  assert_df_with_variables(data, list(rsp = "rsp", grp = "grp", strata = "strata"))
  checkmate::assert_multi_class(data$grp, classes = c("factor", "character"))
  checkmate::assert_multi_class(data$strata, classes = c("factor", "character"))

  data$grp <- as_factor_keep_attributes(data$grp)
  data$strata <- as_factor_keep_attributes(data$strata)

  # Deviation from convention: `survival::strata` must be simply `strata`.
  formula <- stats::as.formula("rsp ~ grp + strata(strata)")
  model_fit <- clogit_with_tryCatch(formula = formula, data = data)

  # Create a list with one set of OR estimates and CI per coefficient, i.e.
  # comparison of one group vs. the reference group.
  coef_est <- stats::coef(model_fit)
  ci_est <- stats::confint(model_fit, level = conf_level)
  or_ci <- list()
  for (coef_name in names(coef_est)) {
    grp_name <- gsub("^grp", "", x = coef_name)
    or_ci[[grp_name]] <- stats::setNames(
      object = exp(c(coef_est[coef_name], ci_est[coef_name, , drop = TRUE])),
      nm = c("est", "lcl", "ucl")
    )
  }
  list(or_ci = or_ci, n_tot = c(n_tot = model_fit$n))
}

#' Tabulate Binary Response by Subgroup
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Tabulate statistics such as response rate and odds ratio for population subgroups.
#'
#' @details These functions create a layout starting from a data frame which contains
#'   the required statistics. Tables typically used as part of forest plot.
#'
#' @inheritParams argument_convention
#' @param data (`data.frame`)\cr the dataset containing the variables to summarize.
#' @param groups_lists (named `list` of `list`)\cr optionally contains for each `subgroups` variable a
#'   list, which specifies the new group levels via the names and the
#'   levels that belong to it in the character vectors that are elements of the list.
#' @param label_all (`string`)\cr label for the total population analysis.
#' @param method (`string`)\cr specifies the test used to calculate the p-value for the difference between
#'   two proportions. For options, see [s_test_proportion_diff()]. Default is `NULL` so no test is performed.
#' @name response_subgroups
#' @seealso [extract_rsp_subgroups()]
#'
#' @examples
#' library(dplyr)
#' library(forcats)
#'
#' adrs <- tern_ex_adrs
#' adrs_labels <- formatters::var_labels(adrs)
#'
#' adrs_f <- adrs %>%
#'   filter(PARAMCD == "BESRSPI") %>%
#'   filter(ARM %in% c("A: Drug X", "B: Placebo")) %>%
#'   droplevels() %>%
#'   mutate(
#'     # Reorder levels of factor to make the placebo group the reference arm.
#'     ARM = fct_relevel(ARM, "B: Placebo"),
#'     rsp = AVALC == "CR"
#'   )
#' formatters::var_labels(adrs_f) <- c(adrs_labels, "Response")
#'
#' # Unstratified analysis.
#' df <- extract_rsp_subgroups(
#'   variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
#'   data = adrs_f
#' )
#' df
NULL

#' Prepares Response Data for Population Subgroups in Data Frames
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Prepares response rates and odds ratios for population subgroups in data frames. Simple wrapper
#' for [h_odds_ratio_subgroups_df()] and [h_proportion_subgroups_df()].
#'   Result is a list of two data frames: `prop` and `or`.
#'   `variables` corresponds to the names of variables found in `data`, passed as a named
#'   list and requires elements `rsp`, `arm` and optionally `subgroups` and `strat`.
#'   `groups_lists` optionally specifies groupings for `subgroups` variables.
#'
#' @inheritParams argument_convention
#' @inheritParams response_subgroups
#' @param label_all (`string`)\cr label for the total population analysis.
#' @seealso [response_subgroups]
#' @export
#'
#' @examples
#' library(dplyr)
#' library(forcats)
#'
#' adrs <- tern_ex_adrs
#' adrs_labels <- formatters::var_labels(adrs)
#'
#' adrs_f <- adrs %>%
#'   filter(PARAMCD == "BESRSPI") %>%
#'   filter(ARM %in% c("A: Drug X", "B: Placebo")) %>%
#'   droplevels() %>%
#'   mutate(
#'     # Reorder levels of factor to make the placebo group the reference arm.
#'     ARM = fct_relevel(ARM, "B: Placebo"),
#'     rsp = AVALC == "CR"
#'   )
#' formatters::var_labels(adrs_f) <- c(adrs_labels, "Response")
#'
#' # Unstratified analysis.
#' df <- extract_rsp_subgroups(
#'   variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
#'   data = adrs_f
#' )
#' df
#'
#' # Stratified analysis.
#' df_strat <- extract_rsp_subgroups(
#'   variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2"), strat = "STRATA1"),
#'   data = adrs_f
#' )
#' df_strat
#'
#' # Grouping of the BMRKR2 levels.
#' df_grouped <- extract_rsp_subgroups(
#'   variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
#'   data = adrs_f,
#'   groups_lists = list(
#'     BMRKR2 = list(
#'       "low" = "LOW",
#'       "low/medium" = c("LOW", "MEDIUM"),
#'       "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
#'     )
#'   )
#' )
#' df_grouped
extract_rsp_subgroups <- function(variables,
                                  data,
                                  groups_lists = list(),
                                  conf_level = 0.95,
                                  method = NULL,
                                  label_all = "All Patients") {
  df_prop <- h_proportion_subgroups_df(
    variables,
    data,
    groups_lists = groups_lists,
    label_all = label_all
  )
  df_or <- h_odds_ratio_subgroups_df(
    variables,
    data,
    groups_lists = groups_lists,
    conf_level = conf_level,
    method = method,
    label_all = label_all
  )

  list(prop = df_prop, or = df_or)
}

#' @describeIn response_subgroups Formatted Analysis function used to format the results of [extract_rsp_subgroups()].
#'   Returns is a list of Formatted Analysis functions with one element per statistic.
#'
#' @examples
#' # Internal function - a_response_subgroups
#' \dontrun{
#' a_response_subgroups(.formats = list("n" = "xx", "prop" = "xx.xx%"))
#' }
#'
#' @keywords internal
a_response_subgroups <- function(.formats = list(
                                   n = "xx",
                                   n_rsp = "xx",
                                   prop = "xx.x%",
                                   n_tot = "xx",
                                   or = list(format_extreme_values(2L)),
                                   ci = list(format_extreme_values_ci(2L)),
                                   pval = "x.xxxx | (<0.0001)"
                                 )) {
  checkmate::assert_list(.formats)
  checkmate::assert_subset(
    names(.formats),
    c("n", "n_rsp", "prop", "n_tot", "or", "ci", "pval")
  )

  afun_lst <- Map(
    function(stat, fmt) {
      if (stat == "ci") {
        function(df, labelstr = "", ...) {
          in_rows(.list = combine_vectors(df$lcl, df$ucl), .labels = as.character(df$subgroup), .formats = fmt)
        }
      } else {
        function(df, labelstr = "", ...) {
          in_rows(.list = as.list(df[[stat]]), .labels = as.character(df$subgroup), .formats = fmt)
        }
      }
    },
    stat = names(.formats),
    fmt = .formats
  )

  afun_lst
}

#' @describeIn response_subgroups table creating function.
#' @param df (`list`)\cr of data frames containing all analysis variables. List should be
#'   created using [extract_rsp_subgroups()].
#' @param vars (`character`)\cr the name of statistics to be reported among
#'  `n` (total number of observations per group),
#'  `n_rsp` (number of responders per group),
#'  `prop` (proportion of responders),
#'  `n_tot` (total number of observations),
#'  `or` (odds ratio),
#'  `ci` (confidence interval of odds ratio) and
#'  `pval` (p value of the effect).
#'  Note, the statistics `n_tot`, `or` and `ci` are required.
#' @export
#'
#' @examples
#' ## Table with default columns.
#' basic_table() %>%
#'   tabulate_rsp_subgroups(df)
#'
#' ## Table with selected columns.
#' basic_table() %>%
#'   tabulate_rsp_subgroups(
#'     df = df,
#'     vars = c("n_tot", "n", "n_rsp", "prop", "or", "ci")
#'   )
tabulate_rsp_subgroups <- function(lyt,
                                   df,
                                   vars = c("n_tot", "n", "prop", "or", "ci")) {
  conf_level <- df$or$conf_level[1]
  method <- if ("pval_label" %in% names(df$or)) {
    df$or$pval_label[1]
  } else {
    NULL
  }

  afun_lst <- a_response_subgroups()
  colvars <- d_rsp_subgroups_colvars(vars, conf_level = conf_level, method = method)

  colvars_prop <- list(
    vars = colvars$vars[names(colvars$labels) %in% c("n", "prop", "n_rsp")],
    labels = colvars$labels[names(colvars$labels) %in% c("n", "prop", "n_rsp")]
  )
  colvars_or <- list(
    vars = colvars$vars[names(colvars$labels) %in% c("n_tot", "or", "ci", "pval")],
    labels = colvars$labels[names(colvars$labels) %in% c("n_tot", "or", "ci", "pval")]
  )

  # Columns from table_prop are optional.
  if (length(colvars_prop$vars) > 0) {
    lyt_prop <- split_cols_by(lyt = lyt, var = "arm")
    lyt_prop <- split_rows_by(
      lyt = lyt_prop,
      var = "row_type",
      split_fun = keep_split_levels("content"),
      nested = FALSE
    )
    lyt_prop <- summarize_row_groups(
      lyt = lyt_prop,
      var = "var_label",
      cfun = afun_lst[names(colvars_prop$labels)]
    )
    lyt_prop <- split_cols_by_multivar(
      lyt = lyt_prop,
      vars = colvars_prop$vars,
      varlabels = colvars_prop$labels
    )

    if ("analysis" %in% df$prop$row_type) {
      lyt_prop <- split_rows_by(
        lyt = lyt_prop,
        var = "row_type",
        split_fun = keep_split_levels("analysis"),
        nested = FALSE,
        child_labels = "hidden"
      )
      lyt_prop <- split_rows_by(lyt = lyt_prop, var = "var_label", nested = TRUE)
      lyt_prop <- analyze_colvars(
        lyt = lyt_prop,
        afun = afun_lst[names(colvars_prop$labels)],
        inclNAs = TRUE
      )
    }

    table_prop <- build_table(lyt_prop, df = df$prop)
  } else {
    table_prop <- NULL
  }

  # Columns "n_tot", "or", "ci" in table_or are required.
  lyt_or <- split_cols_by(lyt = lyt, var = "arm")
  lyt_or <- split_rows_by(
    lyt = lyt_or,
    var = "row_type",
    split_fun = keep_split_levels("content"),
    nested = FALSE
  )
  lyt_or <- split_cols_by_multivar(
    lyt = lyt_or,
    vars = colvars_or$vars,
    varlabels = colvars_or$labels
  )
  lyt_or <- summarize_row_groups(
    lyt = lyt_or,
    var = "var_label",
    cfun = afun_lst[names(colvars_or$labels)]
  ) %>%
    append_topleft("Baseline Risk Factors")

  if ("analysis" %in% df$or$row_type) {
    lyt_or <- split_rows_by(
      lyt = lyt_or,
      var = "row_type",
      split_fun = keep_split_levels("analysis"),
      nested = FALSE,
      child_labels = "hidden"
    )
    lyt_or <- split_rows_by(lyt = lyt_or, var = "var_label", nested = TRUE)
    lyt_or <- analyze_colvars(
      lyt = lyt_or,
      afun = afun_lst[names(colvars_or$labels)],
      inclNAs = TRUE
    )
  }
  table_or <- build_table(lyt_or, df = df$or)

  n_tot_id <- match("n_tot", colvars_or$vars)
  if (is.null(table_prop)) {
    result <- table_or
    or_id <- match("or", colvars_or$vars)
    ci_id <- match("lcl", colvars_or$vars)
  } else {
    result <- cbind_rtables(table_or[, n_tot_id], table_prop, table_or[, -n_tot_id])
    or_id <- 1L + ncol(table_prop) + match("or", colvars_or$vars[-n_tot_id])
    ci_id <- 1L + ncol(table_prop) + match("lcl", colvars_or$vars[-n_tot_id])
    n_tot_id <- 1L
  }
  structure(
    result,
    forest_header = paste0(levels(df$prop$arm), "\nBetter"),
    col_x = or_id,
    col_ci = ci_id,
    col_symbol_size = n_tot_id
  )
}

#' Labels for Column Variables in Binary Response by Subgroup Table
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Internal function to check variables included in
#' [tabulate_rsp_subgroups] and create column labels.
#'
#' @inheritParams argument_convention
#' @inheritParams tabulate_rsp_subgroups
#'
#' @return `list` of variables to tabulate and their labels.
#'
#' @export
d_rsp_subgroups_colvars <- function(vars,
                                    conf_level = NULL,
                                    method = NULL) {
  checkmate::assert_character(vars)
  checkmate::assert_subset(c("n_tot", "or", "ci"), vars)
  checkmate::assert_subset(
    vars,
    c("n", "n_rsp", "prop", "n_tot", "or", "ci", "pval")
  )

  varlabels <- c(
    n = "n",
    n_rsp = "Responders",
    prop = "Response (%)",
    n_tot = "Total n",
    or = "Odds Ratio"
  )
  colvars <- vars

  if ("ci" %in% colvars) {
    checkmate::assert_false(is.null(conf_level))

    varlabels <- c(
      varlabels,
      ci = paste0(100 * conf_level, "% CI")
    )

    # The `lcl`` variable is just a placeholder available in the analysis data,
    # it is not acutally used in the tabulation.
    # Variables used in the tabulation are lcl and ucl, see `a_response_subgroups` for details.
    colvars[colvars == "ci"] <- "lcl"
  }

  if ("pval" %in% colvars) {
    varlabels <- c(
      varlabels,
      pval = method
    )
  }

  list(
    vars = colvars,
    labels = varlabels[vars]
  )
}

#' @include control_step.R
NULL

#' Helper Functions for Subgroup Treatment Effect Pattern (STEP) Calculations
#'
#' @description`r lifecycle::badge("stable")`
#'
#' Helper functions that are used internally for the STEP calculations.
#'
#' @inheritParams argument_convention
#' @name h_step
#'
NULL

#' @describeIn h_step creates the windows for STEP, based on the control settings
#'   provided. Returns a list containing the window-selection matrix `sel`
#'   and the interval information matrix `interval`.
#'
#' @param x (`numeric`)\cr biomarker value(s) to use (without `NA`).
#' @param control (named `list`)\cr output from `control_step()`.
#'
#' @export
h_step_window <- function(x,
                          control = control_step()) {
  checkmate::assert_numeric(x, min.len = 1, any.missing = FALSE)
  checkmate::assert_list(control, names = "named")

  sel <- matrix(FALSE, length(x), control$num_points)
  out <- matrix(0, control$num_points, 3)
  colnames(out) <- paste("Interval", c("Center", "Lower", "Upper"))
  if (control$use_percentile) {
    # Create windows according to percentile cutoffs.
    out <- cbind(out, out)
    colnames(out)[1:3] <- paste("Percentile", c("Center", "Lower", "Upper"))
    xs <- seq(0, 1, length = control$num_points + 2)[-1]
    for (i in seq_len(control$num_points)) {
      out[i, 2:3] <- c(
        max(xs[i] - control$bandwidth, 0),
        min(xs[i] + control$bandwidth, 1)
      )
      out[i, 5:6] <- stats::quantile(x, out[i, 2:3])
      sel[, i] <- x >= out[i, 5] & x <= out[i, 6]
    }
    # Center is the middle point of the percentile window.
    out[, 1] <- xs[-control$num_points - 1]
    out[, 4] <- stats::quantile(x, out[, 1])
  } else {
    # Create windows according to cutoffs.
    m <- c(min(x), max(x))
    xs <- seq(m[1], m[2], length = control$num_points + 2)[-1]
    for (i in seq_len(control$num_points)) {
      out[i, 2:3] <- c(
        max(xs[i] - control$bandwidth, m[1]),
        min(xs[i] + control$bandwidth, m[2])
      )
      sel[, i] <- x >= out[i, 2] & x <= out[i, 3]
    }
    # Center is the same as the point for predicting.
    out[, 1] <- xs[-control$num_points - 1]
  }
  list(sel = sel, interval = out)
}

#' @describeIn h_step calculates the estimated treatment effect estimate
#'   on the linear predictor scale and corresponding standard error from a STEP `model` fitted
#'   on `data` given `variables` specification, for a single biomarker value `x`.
#'   This works for both `coxph` and `glm` models, i.e. for calculating log hazard ratio or log odds
#'   ratio estimates. It returns a vector with elements `est` and `se`.
#' @param model the regression model object.
#'
#' @export
h_step_trt_effect <- function(data,
                              model,
                              variables,
                              x) {
  checkmate::assert_multi_class(model, c("coxph", "glm"))
  checkmate::assert_number(x)
  assert_df_with_variables(data, variables)
  checkmate::assert_factor(data[[variables$arm]], n.levels = 2)

  newdata <- data[c(1, 1), ]
  newdata[, variables$biomarker] <- x
  newdata[, variables$arm] <- levels(data[[variables$arm]])
  model_terms <- stats::delete.response(stats::terms(model))
  model_frame <- stats::model.frame(model_terms, data = newdata, xlev = model$xlevels)
  mat <- stats::model.matrix(model_terms, data = model_frame, contrasts.arg = model$contrasts)
  coefs <- stats::coef(model)
  # Note: It is important to use the coef subset from matrix, otherwise intercept and
  # strata are included for coxph() models.
  mat <- mat[, names(coefs)]
  mat_diff <- diff(mat)
  est <- mat_diff %*% coefs
  var <- mat_diff %*% stats::vcov(model) %*% t(mat_diff)
  se <- sqrt(var)
  c(
    est = est,
    se = se
  )
}

#' @describeIn h_step builds the model formula used in survival STEP calculations.
#'
#' @export
h_step_survival_formula <- function(variables,
                                    control = control_step()) {
  checkmate::assert_character(variables$covariates, null.ok = TRUE)

  assert_list_of_variables(variables[c("arm", "biomarker", "event", "time")])
  form <- paste0("Surv(", variables$time, ", ", variables$event, ") ~ ", variables$arm)
  if (control$degree > 0) {
    form <- paste0(form, " * stats::poly(", variables$biomarker, ", degree = ", control$degree, ", raw = TRUE)")
  }
  if (!is.null(variables$covariates)) {
    form <- paste(form, "+", paste(variables$covariates, collapse = "+"))
  }
  if (!is.null(variables$strata)) {
    form <- paste0(form, " + strata(", paste0(variables$strata, collapse = ", "), ")")
  }
  stats::as.formula(form)
}

#' @describeIn h_step estimates the model with `formula` built based on
#'   `variables` in `data` for a given `subset` and `control` parameters for the
#'   Cox regression, and returns a matrix of number of observations `n`,
#'   `events` as well as log hazard ratio estimates `loghr`, standard error `se`
#'   and Wald confidence interval bounds `ci_lower` and `ci_upper`. One row is
#'   included here for each biomarker value in `x`.
#' @param formula (`formula`)\cr the regression model formula.
#' @param subset (`logical`)\cr subset vector.
#'
#' @export
h_step_survival_est <- function(formula,
                                data,
                                variables,
                                x,
                                subset = rep(TRUE, nrow(data)),
                                control = control_coxph()) {
  checkmate::assert_formula(formula)
  assert_df_with_variables(data, variables)
  checkmate::assert_logical(subset, min.len = 1, any.missing = FALSE)
  checkmate::assert_numeric(x, min.len = 1, any.missing = FALSE)
  checkmate::assert_list(control, names = "named")

  # Note: `subset` in `coxph` needs to be an expression referring to `data` variables.
  data$.subset <- subset
  coxph_warnings <- NULL
  tryCatch(
    withCallingHandlers(
      expr = {
        fit <- survival::coxph(
          formula = formula,
          data = data,
          subset = .subset,
          ties = control$ties
        )
      },
      warning = function(w) {
        coxph_warnings <<- c(coxph_warnings, w)
        invokeRestart("muffleWarning")
      }
    ),
    finally = {
    }
  )
  if (!is.null(coxph_warnings)) {
    warning(paste(
      "Fit warnings occurred, please consider using a simpler model, or",
      "larger `bandwidth`, less `num_points` in `control_step()` settings"
    ))
  }
  # Produce a matrix with one row per `x` and columns `est` and `se`.
  estimates <- t(vapply(
    X = x,
    FUN = h_step_trt_effect,
    FUN.VALUE = c(1, 2),
    data = data,
    model = fit,
    variables = variables
  ))
  q_norm <- stats::qnorm((1 + control$conf_level) / 2)
  cbind(
    n = fit$n,
    events = fit$nevent,
    loghr = estimates[, "est"],
    se = estimates[, "se"],
    ci_lower = estimates[, "est"] - q_norm * estimates[, "se"],
    ci_upper = estimates[, "est"] + q_norm * estimates[, "se"]
  )
}

#' @describeIn h_step builds the model formula used in response STEP calculations.
#'
#' @export
h_step_rsp_formula <- function(variables,
                               control = c(control_step(), control_logistic())) {
  checkmate::assert_character(variables$covariates, null.ok = TRUE)
  assert_list_of_variables(variables[c("arm", "biomarker", "response")])
  response_definition <- sub(
    pattern = "response",
    replacement = variables$response,
    x = control$response_definition,
    fixed = TRUE
  )
  form <- paste0(response_definition, " ~ ", variables$arm)
  if (control$degree > 0) {
    form <- paste0(form, " * stats::poly(", variables$biomarker, ", degree = ", control$degree, ", raw = TRUE)")
  }
  if (!is.null(variables$covariates)) {
    form <- paste(form, "+", paste(variables$covariates, collapse = "+"))
  }
  if (!is.null(variables$strata)) {
    strata_arg <- if (length(variables$strata) > 1) {
      paste0("I(interaction(", paste0(variables$strata, collapse = ", "), "))")
    } else {
      variables$strata
    }
    form <- paste0(form, "+ strata(", strata_arg, ")")
  }
  stats::as.formula(form)
}

#' @describeIn h_step estimates the model with `formula` built based on
#'   `variables` in `data` for a given `subset` and `control` parameters for the
#'   logistic regression, and returns a matrix of number of observations `n`
#'   as well as log odds ratio estimates `logor`, standard error `se`
#'   and Wald confidence interval bounds `ci_lower` and `ci_upper`. One row is
#'   included here for each biomarker value in `x`.
#' @param formula (`formula`)\cr the regression model formula.
#' @param subset (`logical`)\cr subset vector.
#'
#' @export
h_step_rsp_est <- function(formula,
                           data,
                           variables,
                           x,
                           subset = rep(TRUE, nrow(data)),
                           control = control_logistic()) {
  checkmate::assert_formula(formula)
  assert_df_with_variables(data, variables)
  checkmate::assert_logical(subset, min.len = 1, any.missing = FALSE)
  checkmate::assert_numeric(x, min.len = 1, any.missing = FALSE)
  checkmate::assert_list(control, names = "named")
  # Note: `subset` in `glm` needs to be an expression referring to `data` variables.
  data$.subset <- subset
  fit_warnings <- NULL
  tryCatch(
    withCallingHandlers(
      expr = {
        fit <- if (is.null(variables$strata)) {
          stats::glm(
            formula = formula,
            data = data,
            subset = .subset,
            family = stats::binomial("logit")
          )
        } else {
          # clogit needs coxph and strata imported
          survival::clogit(
            formula = formula,
            data = data,
            subset = .subset
          )
        }
      },
      warning = function(w) {
        fit_warnings <<- c(fit_warnings, w)
        invokeRestart("muffleWarning")
      }
    ),
    finally = {
    }
  )
  if (!is.null(fit_warnings)) {
    warning(paste(
      "Fit warnings occurred, please consider using a simpler model, or",
      "larger `bandwidth`, less `num_points` in `control_step()` settings"
    ))
  }
  # Produce a matrix with one row per `x` and columns `est` and `se`.
  estimates <- t(vapply(
    X = x,
    FUN = h_step_trt_effect,
    FUN.VALUE = c(1, 2),
    data = data,
    model = fit,
    variables = variables
  ))
  q_norm <- stats::qnorm((1 + control$conf_level) / 2)
  cbind(
    n = length(fit$y),
    logor = estimates[, "est"],
    se = estimates[, "se"],
    ci_lower = estimates[, "est"] - q_norm * estimates[, "se"],
    ci_upper = estimates[, "est"] + q_norm * estimates[, "se"]
  )
}

#' Cumulative Counts with Thresholds
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Summarize cumulative counts of a (`numeric`) vector that is less than, less or equal to,
#' greater than, or greater or equal to user-specific thresholds.
#'
#' @seealso Relevant helper function [h_count_cumulative()], and descriptive function [d_count_cumulative()]
#'
#' @name count_cumulative
NULL

#' Helper Function for [s_count_cumulative()]
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Helper function to calculate count and fraction of `x` values in the lower or upper tail given a threshold.
#'
#' @inheritParams argument_convention
#' @param threshold (`number`)\cr a cutoff value as threshold to count values of `x`.
#' @param lower_tail (`logical`)\cr whether to count lower tail, default is `TRUE`.
#' @param include_eq (`logical`)\cr whether to include value equal to the `threshold` in
#' count, default is `TRUE`.
#' @param .N_col (`count`)\cr denominator for fraction calculation.
#' @return A named vector with items:
#' \describe{
#'   \item{count}{the count of values less than, less or equal to, greater than, or greater or equal to a threshold
#'     of user specification.
#'   }
#'   \item{fraction}{the fraction of the count.}
#' }
#' @seealso [count_cumulative]
#'
#' @export
#'
#' @examples
#' set.seed(1, kind = "Mersenne-Twister")
#' x <- c(sample(1:10, 10), NA)
#' .N_col <- length(x)
#' h_count_cumulative(x, 5, .N_col = .N_col)
#' h_count_cumulative(x, 5, lower_tail = FALSE, include_eq = FALSE, na.rm = FALSE, .N_col = .N_col)
#' h_count_cumulative(x, 0, lower_tail = FALSE, .N_col = .N_col)
#' h_count_cumulative(x, 100, lower_tail = FALSE, .N_col = .N_col)
h_count_cumulative <- function(x,
                               threshold,
                               lower_tail = TRUE,
                               include_eq = TRUE,
                               na.rm = TRUE, # nolint
                               .N_col) { # nolint
  checkmate::assert_numeric(x)
  checkmate::assert_numeric(threshold)
  checkmate::assert_numeric(.N_col)
  checkmate::assert_flag(lower_tail)
  checkmate::assert_flag(include_eq)
  checkmate::assert_flag(na.rm)

  is_keep <- if (na.rm) !is.na(x) else rep(TRUE, length(x))
  count <- if (lower_tail && include_eq) {
    length(x[is_keep & x <= threshold])
  } else if (lower_tail && !include_eq) {
    length(x[is_keep & x < threshold])
  } else if (!lower_tail && include_eq) {
    length(x[is_keep & x >= threshold])
  } else if (!lower_tail && !include_eq) {
    length(x[is_keep & x > threshold])
  }

  result <- c(count = count, fraction = count / .N_col)
  result
}

#' Description of Cumulative Count
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This is a helper function that describes analysis in [s_count_cumulative()].
#'
#' @inheritParams h_count_cumulative
#' @return a descriptive `string`.
#' @seealso [s_count_cumulative()]
#'
#' @export
d_count_cumulative <- function(threshold, lower_tail, include_eq) {
  checkmate::assert_numeric(threshold)
  lg <- if (lower_tail) "<" else ">"
  eq <- if (include_eq) "=" else ""
  paste0(lg, eq, " ", threshold)
}

#' @describeIn count_cumulative Statistics function that produces a named lists given a numeric vector of thresholds.
#'
#' @inheritParams h_count_cumulative
#' @param thresholds (`numeric`)\cr vector of cutoff value for the counts.
#' @return A named list of `count_fraction`s: a list with each `thresholds` value as a component, each component
#'     contains a vector for the count and fraction.
#'
#' @examples
#' # Internal function - s_count_cumulative
#' \dontrun{
#' set.seed(1, kind = "Mersenne-Twister")
#' x <- c(sample(1:10, 10), NA)
#' .N_col <- length(x)
#' s_count_cumulative(x, thresholds = c(0, 5, 11), .N_col = .N_col)
#' s_count_cumulative(x, thresholds = c(0, 5, 11), include_eq = FALSE, na.rm = FALSE, .N_col = .N_col)
#' }
#'
#' @keywords internal
s_count_cumulative <- function(x,
                               thresholds,
                               lower_tail = TRUE,
                               include_eq = TRUE,
                               .N_col, # nolint
                               ...) {
  checkmate::assert_numeric(thresholds, min.len = 1, any.missing = FALSE)

  count_fraction_list <- Map(function(thres) {
    result <- h_count_cumulative(x, thres, lower_tail, include_eq, .N_col = .N_col, ...)
    label <- d_count_cumulative(thres, lower_tail, include_eq)
    formatters::with_label(result, label)
  }, thresholds)

  names(count_fraction_list) <- thresholds
  list(count_fraction = count_fraction_list)
}

#' @describeIn count_cumulative Formatted Analysis function which can be further customized by calling
#'   [rtables::make_afun()] on it. It is used as `afun` in [rtables::analyze()].
#'
#' @return [a_count_cumulative()] returns the corresponding list with formatted [rtables::CellValue()].
#'
#' @examples
#' # Internal function - a_count_cumulative
#' \dontrun{
#' # Use the Formatted Analysis function for `analyze()`. We need to ungroup `count_fraction` first
#' # so that the `rtables` formatting function `format_count_fraction()` can be applied correctly.
#' afun <- make_afun(a_count_cumulative, .ungroup_stats = "count_fraction")
#' afun(x, thresholds = c(0, 5, 11), .N_col = .N_col)
#' }
#'
#' @keywords internal
a_count_cumulative <- make_afun(
  s_count_cumulative,
  .formats = c(count_fraction = format_count_fraction)
)

#' @describeIn count_cumulative Layout creating function which can be be used for creating
#'   summary tables for cumulative counts of a variable. The ellipsis (`...`) conveys
#'   arguments to `s_count_cumulative()`, for instance `lower_tail = FALSE` if upper tail
#'   should be accounted for.
#'
#' @inheritParams argument_convention
#' @export
#'
#' @examples
#' basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   add_colcounts() %>%
#'   count_cumulative(
#'     vars = "AGE",
#'     thresholds = c(40, 60)
#'   ) %>%
#'   build_table(tern_ex_adsl)
count_cumulative <- function(lyt,
                             vars,
                             var_labels = vars,
                             show_labels = "visible",
                             ...,
                             table_names = vars,
                             .stats = NULL,
                             .formats = NULL,
                             .labels = NULL,
                             .indent_mods = NULL) {
  afun <- make_afun(
    a_count_cumulative,
    .stats = .stats,
    .formats = .formats,
    .labels = .labels,
    .indent_mods = .indent_mods,
    .ungroup_stats = "count_fraction"
  )
  analyze(
    lyt,
    vars,
    afun = afun,
    table_names = table_names,
    var_labels = var_labels,
    show_labels = show_labels,
    extra_args = list(...)
  )
}

#' Generate PK reference dataset
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @return dataframe of PK parameters
#' @export
#'
#' @examples
#' pk_reference_dataset <- d_pkparam()
d_pkparam <- function() {
  pk_dataset <- as.data.frame(matrix(
    c(
      "TMAX", "Time of CMAX", "Tmax", "Plasma/Blood/Serum", "1",
      "CMAX", "Max Conc", "Cmax", "Plasma/Blood/Serum", "2",
      "CMAXD", "Max Conc Norm by Dose", "Cmax/D", "Plasma/Blood/Serum", "3",
      "AUCIFO", "AUC Infinity Obs", "AUCinf obs", "Plasma/Blood/Serum", "4",
      "AUCIFP", "AUC Infinity Pred", "AUCinf pred", "Plasma/Blood/Serum", "5",
      "AUCIFOD", "AUC Infinity Obs Norm by Dose", "AUCinf/D obs", "Plasma/Blood/Serum", "6",
      "AUCIFD", "AUC Infinity Pred Norm by Dose", "AUCinf/D pred", "Plasma/Blood/Serum", "7",
      "AUCPEO", "AUC %Extrapolation Obs", "AUCinf extrap obs", "Plasma/Blood/Serum", "8",
      "AUCPEP", "AUC %Extrapolation Pred", "AUCinf extrap pred", "Plasma/Blood/Serum", "9",
      "AUCINT", "AUC from T1 to T2", "AUCupper-lower ", "Plasma/Blood/Serum", "10",
      "AUCTAU", "AUC Over Dosing Interval", "AUCtau", "Plasma/Blood/Serum", "11",
      "AUCLST", "AUC to Last Nonzero Conc", "AUClast", "Plasma/Blood/Serum", "12",
      "AUCALL", "AUC All", "AUCall", "Plasma/Blood/Serum", "13",
      "AUMCIFO", "AUMC Infinity Obs", "AUMCinf obs", "Plasma/Blood/Serum", "14",
      "AUMCIFP", "AUMC Infinity Pred", "AUMCinf pred", "Plasma/Blood/Serum", "15",
      "AUMCPEO", "AUMC % Extrapolation Obs", "AUMC extrap obs", "Plasma/Blood/Serum", "16",
      "AUMCPEP", "AUMC % Extrapolation Pred", "AUMC extrap pred", "Plasma/Blood/Serum", "17",
      "AUMCTAU", "AUMC Over Dosing Interval", "AUMCtau", "Plasma/Blood/Serum", "18",
      "AUMCLST", "AUMC to Last Nonzero Conc", "AUMClast", "Plasma/Blood/Serum", "19",
      "AURCIFO", "AURC Infinity Obs", "AURCinf obs", "Plasma/Blood/Serum", "20",
      "AURCIFP", "AURC Infinity Pred", "AURCinf pred", "Plasma/Blood/Serum", "21",
      "AURCPEO", "AURC % Extrapolation Obs", "AURC extrap obs", "Plasma/Blood/Serum", "22",
      "AURCPEP", "AURC % Extrapolation Pred", "AURC extrap pred", "Plasma/Blood/Serum", "23",
      "AURCLST", "AURC Dosing to Last Conc", "AURClast", "Plasma/Blood/Serum", "24",
      "AURCALL", "AURC All", "AURCall", "Plasma/Blood/Serum", "25",
      "TLST", "Time of Last Nonzero Conc", "Tlast", "Plasma/Blood/Serum", "26",
      "CO", "Initial Conc", "CO", "Plasma/Blood/Serum", "27",
      "C0", "Initial Conc", "C0", "Plasma/Blood/Serum", "28",
      "CAVG", "Average Conc", "Cavg", "Plasma/Blood/Serum", "29",
      "CLST", "Last Nonzero Conc", "Clast", "Plasma/Blood/Serum", "30",
      "CMIN", "Min Conc", "Cmin", "Plasma/Blood/Serum", "31",
      "LAMZHL", "Half-Life Lambda z", "t1/2", "Plasma/Blood/Serum", "32",
      "CLFO", "Total CL Obs by F", "CL/F obs", "Plasma/Blood/Serum", "33",
      "CLFP", "Total CL Pred by F", "CL/F pred", "Plasma/Blood/Serum", "34",
      "CLO", "Total CL Obs", "CL obs", "Plasma/Blood/Serum", "35",
      "CLP", "Total CL Pred", "CL pred", "Plasma/Blood/Serum", "36",
      "CLSS", "Total CL Steady State Pred", "CLss", "Plasma/Blood/Serum", "37",
      "CLSSF", "Total CL Steady State Pred by F", "CLss/F", "Plasma/Blood/Serum", "38",
      "VZFO", "Vz Obs by F", "Vz/F obs", "Plasma/Blood/Serum", "39",
      "VZFP", "Vz Pred by F", "Vz/F pred", "Plasma/Blood/Serum", "40",
      "VZO", "Vz Obs", "Vz obs", "Plasma/Blood/Serum", "41",
      "VZP", "Vz Pred", "Vz pred", "Plasma/Blood/Serum", "42",
      "VSSO", "Vol Dist Steady State Obs", "Vss obs", "Plasma/Blood/Serum", "43",
      "VSSP", "Vol Dist Steady State Pred", "Vss pred", "Plasma/Blood/Serum", "44",
      "LAMZ", "Lambda z", "Lambda z", "Plasma/Blood/Serum", "45",
      "LAMZLL", "Lambda z Lower Limit", "Lambda z lower", "Plasma/Blood/Serum", "46",
      "LAMZUL", "Lambda z Upper Limit", "Lambda z upper", "Plasma/Blood/Serum", "47",
      "LAMZNPT", "Number of Points for Lambda z", "No points Lambda z", "Plasma/Blood/Serum", "48",
      "MRTIFO", "MRT Infinity Obs", "MRTinf obs", "Plasma/Blood/Serum", "49",
      "MRTIFP", "MRT Infinity Pred", "MRTinf pred", "Plasma/Blood/Serum", "50",
      "MRTLST", "MRT to Last Nonzero Conc", "MRTlast", "Plasma/Blood/Serum", "51",
      "R2", "R Squared", "Rsq", "Plasma/Blood/Serum", "52",
      "R2ADJ", "R Squared Adjusted", "Rsq adjusted", "Plasma/Blood/Serum", "53",
      "TLAG", "Time Until First Nonzero Conc", "TIag", "Plasma/Blood/Serum", "54",
      "TMIN", "Time of CMIN Observation", "Tmin", "Plasma/Blood/Serum", "55",
      "ACCI", "Accumulation Index", "Accumulation Index", "Plasma/Blood/Serum/Urine", "56",
      "FLUCP", "Fluctuation%", "Fluctuation", "Plasma/Blood/Serum", "57",
      "CORRXY", "Correlation Between TimeX and Log ConcY", "Corr xy", "Plasma/Blood/Serum", "58",
      "RCAMINT", "Amt Rec from T1 to T2", "Ae", "Urine", "59",
      "RCPCINT", "Pct Rec from T1 to T2", "Fe", "Urine", "60",
      "VOLPK", "Sum of Urine Vol", "Urine volume", "Urine", "61",
      "RENALCL", "Renal CL", "CLR", "Plasma/Blood/Serum/Urine", "62",
      "ERTMAX", "Time of Max Excretion Rate", "Tmax Rate", "Urine", "63",
      "RMAX", "Time of Maximum Response", "Rmax", "Matrix of PD", "64",
      "RMIN", "Time of Minimum Response", "Rmin", "Matrix of PD", "65",
      "ERMAX", "Max Excretion Rate", "Max excretion rate", "Urine", "66",
      "MIDPTLST", "Midpoint of Collection Interval", "Midpoint last", "Urine", "67",
      "ERLST", "Last Meas Excretion Rate", "Rate last", "Urine", "68",
      "TON", "Time to Onset", "Tonset", "Matrix of PD", "69",
      "TOFF", "Time to Offset", "Toffset", "Matrix of PD", "70",
      "TBBLP", "Time Below Baseline %", "Time %Below Baseline", "Matrix of PD", "71",
      "TBTP", "Time Below Threshold %", "Time %Below Threshold", "Matrix of PD", "72",
      "TABL", "Time Above Baseline", "Time Above Baseline", "Matrix of PD", "73",
      "TAT", "Time Above Threshold", "Time Above Threshold", "Matrix of PD", "74",
      "TBT", "Time Below Threshold", "Time Below Threshold", "Matrix of PD", "75",
      "TBLT", "Time Between Baseline and Threshold", "Time Between Baseline Threshold", "Matrix of PD", "76",
      "BLRSP", "Baseline Response", "Baseline", "Matrix of PD", "77",
      "TSHDRSP", "Response Threshold", "Threshold", "Matrix of PD", "78",
      "AUCABL", "AUC Above Baseline", "AUC above baseline", "Matrix of PD", "79",
      "AUCAT", "AUC Above Threshold", "AUC above threshold", "Matrix of PD", "80",
      "AUCBBL", "AUC Below Baseline", "AUC below baseline", "Matrix of PD", "81",
      "AUCBT", "AUC Below Threshold", "AUC below threshold", "Matrix of PD", "82",
      "AUCBLDIF", "Diff AUC Above Base and AUC Below Base", "AUC diff baseline", "Matrix of PD", "83",
      "AUCTDIF", "Diff AUC Above Thr and AUC Below Thr", "AUCnet threshold", "Matrix of PD", "84",
      "TDIFF", "Diff Time to Offset and Time to Onset", "Diff toffset-tonset", "Matrix of PD", "85",
      "AUCPBEO", "AUC %Back Extrapolation Obs", "AUC%Back extrap obs", "Plasma/Blood/Serum", "86",
      "AUCPBEP", "AUC %Back Extrapolation Pred", "AUC%Back extrap pred", "Plasma/Blood/Serum", "87",
      "TSLP1L", "Lower Time Limit Slope 1st", "Slope1 lower", "Matrix of PD", "88",
      "TSLP1U", "Upper Time Limit Slope 1st Segment", "Slope1 upper", "Matrix of PD", "89",
      "TSLP2L", "Lower Time Limit Slope 2nd Segment", "Slope2 lower", "Matrix of PD", "90",
      "TSLP2U", "Upper Time Limit Slope 2nd Segment", "Slope2 upper", "Matrix of PD", "91",
      "SLP1", "Slope, 1st Segment", "Slope1", "Matrix of PD", "92",
      "SLP2", "Slope, 2nd Segment", "Slope2", "Matrix of PD", "93",
      "SLP1PT", "Number of Points for Slope 1st Segment", "No points slope1", "Matrix of PD", "94",
      "SLP2PT", "Number of Points for Slope 2nd Segment", "No points slope2", "Matrix of PD", "95",
      "R2ADJS1", "R-Squared Adjusted Slope, 1st Segment", "Rsq adjusted slope1", "Matrix of PD", "96",
      "R2ADJS2", "R-Squared Adjusted Slope, 2nd Segment", "Rsq adjusted slope2", "Matrix of PD", "97",
      "R2SLP1", "R Squared, Slope, 1st Segment", "Rsq slope1", "Matrix of PD", "98",
      "R2SLP2", "R Squared, Slope, 2nd Segment", "Rsq slope2", "Matrix of PD", "99",
      "CORRXYS1", "Corr Btw TimeX and Log ConcY, Slope 1st", "Corr xy slope1", "Plasma/Blood/Serum", "100",
      "CORRXYS2", "Corr Btw TimeX and Log ConcY, Slope 1st Slope 2nd", "Corr xy slope2", "Plasma/Blood/Serum", "101",
      "AILAMZ", "Accumulation Index using Lambda z", "AILAMZ", "Plasma/Blood/Serum", "102",
      "ARAUC", "Accumulation Ratio AUCTAU", "ARAUC", "Plasma/Blood/Serum", "103",
      "ARAUCD", "Accum Ratio AUCTAU norm by dose", "ARAUCD", "Plasma/Blood/Serum", "104",
      "ARAUCIFO", "Accum Ratio AUC Infinity Obs", "ARAUCIFO", "Plasma/Blood/Serum", "105",
      "ARAUCIFP", "Accum Ratio AUC Infinity Pred", "ARAUCIFP", "Plasma/Blood/Serum", "106",
      "ARAUCIND", "Accum Ratio AUC T1 to T2 norm by dose", "ARAUCIND_T1_T2_UNIT", "Plasma/Blood/Serum", "107",
      "ARAUCINT", "Accumulation Ratio AUC from T1 to T2", "ARAUCINT_T1_T2_UNIT", "Plasma/Blood/Serum", "108",
      "ARAUCIOD", "Accum Ratio AUCIFO Norm by Dose", "ARAUCIOD", "Plasma/Blood/Serum", "109",
      "ARAUCIPD", "Accum Ratio AUCIFP Norm by Dose", "ARAUCIPD", "Plasma/Blood/Serum", "110",
      "ARAUCLST", "Accum Ratio AUC to Last Nonzero Conc", "ARAUCLST", "Plasma/Blood/Serum", "111",
      "ARCMAX", "Accumulation Ratio Cmax", "ARCMAX", "Plasma/Blood/Serum", "112",
      "ARCMAXD", "Accum Ratio Cmax norm by dose", "ARCMAXD", "Plasma/Blood/Serum", "113",
      "ARCMIN", "Accumulation Ratio Cmin", "ARCMIN", "Plasma/Blood/Serum", "114",
      "ARCMIND", "Accum Ratio Cmin norm by dose", "ARCMIND", "Plasma/Blood/Serum", "115",
      "ARCTROUD", "Accum Ratio Ctrough norm by dose", "ARCTROUD", "Plasma/Blood/Serum", "116",
      "ARCTROUG", "Accumulation Ratio Ctrough", "ARCTROUG", "Plasma/Blood/Serum", "117",
      "AUCALLB", "AUC All Norm by BMI", "AUCall_B", "Plasma/Blood/Serum", "118",
      "AUCALLD", "AUC All Norm by Dose", "AUCall_D", "Plasma/Blood/Serum", "119",
      "AUCALLS", "AUC All Norm by SA", "AUCall_S", "Plasma/Blood/Serum", "120",
      "AUCALLW", "AUC All Norm by WT", "AUCall_W", "Plasma/Blood/Serum", "121",
      "AUCIFOB", "AUC Infinity Obs Norm by BMI", "AUCINF_obs_B", "Plasma/Blood/Serum", "122",
      "AUCIFOLN", "AUC Infinity Obs LN Transformed", "AUCIFOLN", "Plasma/Blood/Serum", "123",
      "AUCIFOS", "AUC Infinity Obs Norm by SA", "AUCINF_obs_S", "Plasma/Blood/Serum", "124",
      "AUCIFOUB", "AUC Infinity Obs, Unbound Drug", "AUCIFOUB", "Plasma/Blood/Serum", "125",
      "AUCIFOW", "AUC Infinity Obs Norm by WT", "AUCINF_obs_W", "Plasma/Blood/Serum", "126",
      "AUCIFPB", "AUC Infinity Pred Norm by BMI", "AUCINF_pred_B", "Plasma/Blood/Serum", "127",
      "AUCIFPD", "AUC Infinity Pred Norm by Dose", "AUCINF_pred_D", "Plasma/Blood/Serum", "128",
      "AUCIFPS", "AUC Infinity Pred Norm by SA", "AUCINF_pred_S", "Plasma/Blood/Serum", "129",
      "AUCIFPUB", "AUC Infinity Pred, Unbound Drug", "AUCIFPUB", "Plasma/Blood/Serum", "130",
      "AUCIFPW", "AUC Infinity Pred Norm by WT", "AUCINF_pred_W", "Plasma/Blood/Serum", "131",
      "AUCINTB", "AUC from T1 to T2 Norm by BMI", "AUC_B_T1_T2_UNIT", "Plasma/Blood/Serum", "132",
      "AUCINTD", "AUC from T1 to T2 Norm by Dose", "AUC_D_T1_T2_UNIT", "Plasma/Blood/Serum", "133",
      "AUCINTS", "AUC from T1 to T2 Norm by SA", "AUC_S_T1_T2_UNIT", "Plasma/Blood/Serum", "134",
      "AUCINTW", "AUC from T1 to T2 Norm by WT", "AUC_W_T1_T2_UNIT", "Plasma/Blood/Serum", "135",
      "AUCLSTB", "AUC to Last Nonzero Conc Norm by BMI", "AUClast_B", "Plasma/Blood/Serum", "136",
      "AUCLSTD", "AUC to Last Nonzero Conc Norm by Dose", "AUClast_D", "Plasma/Blood/Serum", "137",
      "AUCLSTLN", "AUC to Last Nonzero Conc LN Transformed", "AUCLSTLN", "Plasma/Blood/Serum", "138",
      "AUCLSTS", "AUC to Last Nonzero Conc Norm by SA", "AUClast_S", "Plasma/Blood/Serum", "139",
      "AUCLSTUB", "AUC to Last Nonzero Conc, Unbound Drug", "AUCLSTUB", "Plasma/Blood/Serum", "140",
      "AUCLSTW", "AUC to Last Nonzero Conc Norm by WT", "AUClast_W", "Plasma/Blood/Serum", "141",
      "AUCTAUB", "AUC Over Dosing Interval Norm by BMI", "AUC_TAU_B", "Plasma/Blood/Serum", "142",
      "AUCTAUD", "AUC Over Dosing Interval Norm by Dose", "AUC_TAU_D", "Plasma/Blood/Serum", "143",
      "AUCTAUS", "AUC Over Dosing Interval Norm by SA", "AUC_TAU_S", "Plasma/Blood/Serum", "144",
      "AUCTAUW", "AUC Over Dosing Interval Norm by WT", "AUC_TAU_W", "Plasma/Blood/Serum", "145",
      "AUMCIFOB", "AUMC Infinity Obs Norm by BMI", "AUMCINF_obs_B", "Plasma/Blood/Serum", "146",
      "AUMCIFOD", "AUMC Infinity Obs Norm by Dose", "AUMCINF_obs_D", "Plasma/Blood/Serum", "147",
      "AUMCIFOS", "AUMC Infinity Obs Norm by SA", "AUMCINF_obs_S", "Plasma/Blood/Serum", "148",
      "AUMCIFOW", "AUMC Infinity Obs Norm by WT", "AUMCINF_obs_W", "Plasma/Blood/Serum", "149",
      "AUMCIFPB", "AUMC Infinity Pred Norm by BMI", "AUMCINF_pred_B", "Plasma/Blood/Serum", "150",
      "AUMCIFPD", "AUMC Infinity Pred Norm by Dose", "AUMCINF_pred_D", "Plasma/Blood/Serum", "151",
      "AUMCIFPS", "AUMC Infinity Pred Norm by SA", "AUMCINF_pred_S", "Plasma/Blood/Serum", "152",
      "AUMCIFPW", "AUMC Infinity Pred Norm by WT", "AUMCINF_pred_W", "Plasma/Blood/Serum", "153",
      "AUMCLSTB", "AUMC to Last Nonzero Conc Norm by BMI", "AUMClast_B", "Plasma/Blood/Serum", "154",
      "AUMCLSTD", "AUMC to Last Nonzero Conc Norm by Dose", "AUMClast_D", "Plasma/Blood/Serum", "155",
      "AUMCLSTS", "AUMC to Last Nonzero Conc Norm by SA", "AUMClast_S", "Plasma/Blood/Serum", "156",
      "AUMCLSTW", "AUMC to Last Nonzero Conc Norm by WT", "AUMClast_W", "Plasma/Blood/Serum", "157",
      "AUMCTAUB", "AUMC Over Dosing Interval Norm by BMI", "AUMCTAUB", "Plasma/Blood/Serum", "158",
      "AUMCTAUD", "AUMC Over Dosing Interval Norm by Dose", "AUMCTAUD", "Plasma/Blood/Serum", "159",
      "AUMCTAUS", "AUMC Over Dosing Interval Norm by SA", "AUMCTAUS", "Plasma/Blood/Serum", "160",
      "AUMCTAUW", "AUMC Over Dosing Interval Norm by WT", "AUMCTAUW", "Plasma/Blood/Serum", "161",
      "AURCALLB", "AURC All Norm by BMI", "AURCALLB", "Plasma/Blood/Serum", "162",
      "AURCALLD", "AURC All Norm by Dose", "AURCALLD", "Plasma/Blood/Serum", "163",
      "AURCALLS", "AURC All Norm by SA", "AURCALLS", "Plasma/Blood/Serum", "164",
      "AURCALLW", "AURC All Norm by WT", "AURCALLW", "Plasma/Blood/Serum", "165",
      "AURCIFOB", "AURC Infinity Obs Norm by BMI", "AURCIFOB", "Plasma/Blood/Serum", "166",
      "AURCIFOD", "AURC Infinity Obs Norm by Dose", "AURCIFOD", "Plasma/Blood/Serum", "167",
      "AURCIFOS", "AURC Infinity Obs Norm by SA", "AURCIFOS", "Plasma/Blood/Serum", "168",
      "AURCIFOW", "AURC Infinity Obs Norm by WT", "AURCIFOW", "Plasma/Blood/Serum", "169",
      "AURCIFPB", "AURC Infinity Pred Norm by BMI", "AURCIFPB", "Plasma/Blood/Serum", "170",
      "AURCIFPD", "AURC Infinity Pred Norm by Dose", "AURCIFPD", "Plasma/Blood/Serum", "171",
      "AURCIFPS", "AURC Infinity Pred Norm by SA", "AURCIFPS", "Plasma/Blood/Serum", "172",
      "AURCIFPW", "AURC Infinity Pred Norm by WT", "AURCIFPW", "Plasma/Blood/Serum", "173",
      "AURCINT", "AURC from T1 to T2", "AURCINT_T1_T2_UNIT", "Plasma/Blood/Serum", "174",
      "AURCINTB", "AURC from T1 to T2 Norm by BMI", "AURCINTB_T1_T2_UNIT", "Plasma/Blood/Serum", "175",
      "AURCINTD", "AURC from T1 to T2 Norm by Dose", "AURCINTD_T1_T2_UNIT", "Plasma/Blood/Serum", "176",
      "AURCINTS", "AURC from T1 to T2 Norm by SA", "AURCINTS_T1_T2_UNIT", "Plasma/Blood/Serum", "177",
      "AURCINTW", "AURC from T1 to T2 Norm by WT", "AURCINTW_T1_T2_UNIT", "Plasma/Blood/Serum", "178",
      "AURCLSTB", "AURC to Last Nonzero Rate Norm by BMI", "AURCLSTB", "Plasma/Blood/Serum", "179",
      "AURCLSTD", "AURC to Last Nonzero Rate Norm by Dose", "AURCLSTD", "Plasma/Blood/Serum", "180",
      "AURCLSTS", "AURC to Last Nonzero Rate Norm by SA", "AURCLSTS", "Plasma/Blood/Serum", "181",
      "AURCLSTW", "AURC to Last Nonzero Rate Norm by WT", "AURCLSTW", "Plasma/Blood/Serum", "182",
      "C0B", "Initial Conc Norm by BMI", "C0B", "Plasma/Blood/Serum", "183",
      "C0D", "Initial Conc Norm by Dose", "C0D", "Plasma/Blood/Serum", "184",
      "C0S", "Initial Conc Norm by SA", "C0S", "Plasma/Blood/Serum", "185",
      "C0W", "Initial Conc Norm by WT", "C0W", "Plasma/Blood/Serum", "186",
      "CAVGB", "Average Conc Norm by BMI", "CAVGB", "Plasma/Blood/Serum", "187",
      "CAVGD", "Average Conc Norm by Dose", "CAVGD", "Plasma/Blood/Serum", "188",
      "CAVGINT", "Average Conc from T1 to T2", "CAVGINT_T1_T2_UNIT", "Plasma/Blood/Serum", "189",
      "CAVGINTB", "Average Conc from T1 to T2 Norm by BMI", "CAVGINTB_T1_T2_UNIT", "Plasma/Blood/Serum", "190",
      "CAVGINTD", "Average Conc from T1 to T2 Norm by Dose", "CAVGINTD_T1_T2_UNIT", "Plasma/Blood/Serum", "191",
      "CAVGINTS", "Average Conc from T1 to T2 Norm by SA", "CAVGINTS_T1_T2_UNIT", "Plasma/Blood/Serum", "192",
      "CAVGINTW", "Average Conc from T1 to T2 Norm by WT", "CAVGINTW_T1_T2_UNIT", "Plasma/Blood/Serum", "193",
      "CAVGS", "Average Conc Norm by SA", "CAVGS", "Plasma/Blood/Serum", "194",
      "CAVGW", "Average Conc Norm by WT", "CAVGW", "Plasma/Blood/Serum", "195",
      "CHTMAX", "Concentration at Half Tmax", "CHTMAX", "Plasma/Blood/Serum", "196",
      "CLFOB", "Total CL Obs by F Norm by BMI", "CLFOB", "Plasma/Blood/Serum", "197",
      "CLFOD", "Total CL Obs by F Norm by Dose", "CLFOD", "Plasma/Blood/Serum", "198",
      "CLFOS", "Total CL Obs by F Norm by SA", "CLFOS", "Plasma/Blood/Serum", "199",
      "CLFOW", "Total CL Obs by F Norm by WT", "CLFOW", "Plasma/Blood/Serum", "200",
      "CLFPB", "Total CL Pred by F Norm by BMI", "CLFPB", "Plasma/Blood/Serum", "201",
      "CLFPD", "Total CL Pred by F Norm by Dose", "CLFPD", "Plasma/Blood/Serum", "202",
      "CLFPS", "Total CL Pred by F Norm by SA", "CLFPS", "Plasma/Blood/Serum", "203",
      "CLFPW", "Total CL Pred by F Norm by WT", "CLFPW", "Plasma/Blood/Serum", "204",
      "CLFTAU", "Total CL by F for Dose Int", "CLFTAU", "Plasma/Blood/Serum", "205",
      "CLFTAUB", "Total CL by F for Dose Int Norm by BMI", "CLFTAUB", "Plasma/Blood/Serum", "206",
      "CLFTAUD", "Total CL by F for Dose Int Norm by Dose", "CLFTAUD", "Plasma/Blood/Serum", "207",
      "CLFTAUS", "Total CL by F for Dose Int Norm by SA", "CLFTAUS", "Plasma/Blood/Serum", "208",
      "CLFTAUW", "Total CL by F for Dose Int Norm by WT", "CLFTAUW", "Plasma/Blood/Serum", "209",
      "CLFUB", "Apparent CL for Unbound Drug", "CLFUB", "Plasma/Blood/Serum", "210",
      "CLOB", "Total CL Obs Norm by BMI", "CLOB", "Plasma/Blood/Serum", "211",
      "CLOD", "Total CL Obs Norm by Dose", "CLOD", "Plasma/Blood/Serum", "212",
      "CLOS", "Total CL Obs Norm by SA", "CLOS", "Plasma/Blood/Serum", "213",
      "CLOUB", "Total CL Obs for Unbound Drug", "CLOUB", "Plasma/Blood/Serum", "214",
      "CLOW", "Total CL Obs Norm by WT", "CLOW", "Plasma/Blood/Serum", "215",
      "CLPB", "Total CL Pred Norm by BMI", "CLPB", "Plasma/Blood/Serum", "216",
      "CLPD", "Total CL Pred Norm by Dose", "CLPD", "Plasma/Blood/Serum", "217",
      "CLPS", "Total CL Pred Norm by SA", "CLPS", "Plasma/Blood/Serum", "218",
      "CLPUB", "Total CL Pred for Unbound Drug", "CLPUB", "Plasma/Blood/Serum", "219",
      "CLPW", "Total CL Pred Norm by WT", "CLPW", "Plasma/Blood/Serum", "220",
      "CLRPCLEV", "Renal CL as Pct CL EV", "CLRPCLEV", "Urine", "221",
      "CLRPCLIV", "Renal CL as Pct CL IV", "CLRPCLIV", "Urine", "222",
      "CLSTB", "Last Nonzero Conc Norm by BMI", "CLSTB", "Plasma/Blood/Serum", "223",
      "CLSTD", "Last Nonzero Conc Norm by Dose", "CLSTD", "Plasma/Blood/Serum", "224",
      "CLSTS", "Last Nonzero Conc Norm by SA", "CLSTS", "Plasma/Blood/Serum", "225",
      "CLSTW", "Last Nonzero Conc Norm by WT", "CLSTW", "Plasma/Blood/Serum", "226",
      "CLTAU", "Total CL for Dose Int", "CLTAU", "Plasma/Blood/Serum", "227",
      "CLTAUB", "Total CL for Dose Int Norm by BMI", "CLTAUB", "Plasma/Blood/Serum", "228",
      "CLTAUD", "Total CL for Dose Int Norm by Dose", "CLTAUD", "Plasma/Blood/Serum", "229",
      "CLTAUS", "Total CL for Dose Int Norm by SA", "CLTAUS", "Plasma/Blood/Serum", "230",
      "CLTAUW", "Total CL for Dose Int Norm by WT", "CLTAUW", "Plasma/Blood/Serum", "231",
      "CMAXB", "Max Conc Norm by BMI", "CMAX_B", "Plasma/Blood/Serum", "232",
      "CMAXLN", "Max Conc LN Transformed", "CMAXLN", "Plasma/Blood/Serum", "233",
      "CMAXS", "Max Conc Norm by SA", "CMAXS", "Plasma/Blood/Serum", "234",
      "CMAXUB", "Max Conc, Unbound Drug", "CMAXUB", "Plasma/Blood/Serum", "235",
      "CMAXW", "Max Conc Norm by WT", "CMAXW", "Plasma/Blood/Serum", "236",
      "CMINB", "Min Conc Norm by BMI", "CMINB", "Plasma/Blood/Serum", "237",
      "CMIND", "Min Conc Norm by Dose", "CMIND", "Plasma/Blood/Serum", "238",
      "CMINS", "Min Conc Norm by SA", "CMINS", "Plasma/Blood/Serum", "239",
      "CMINW", "Min Conc Norm by WT", "CMINW", "Plasma/Blood/Serum", "240",
      "CONC", "Concentration", "CONC", "Plasma/Blood/Serum", "241",
      "CONCB", "Conc by BMI", "CONCB", "Plasma/Blood/Serum", "242",
      "CONCD", "Conc by Dose", "CONCD", "Plasma/Blood/Serum", "243",
      "CONCS", "Conc by SA", "CONCS", "Plasma/Blood/Serum", "244",
      "CONCW", "Conc by WT", "CONCW", "Plasma/Blood/Serum", "245",
      "CTROUGH", "Conc Trough", "CTROUGH", "Plasma/Blood/Serum", "246",
      "CTROUGHB", "Conc Trough by BMI", "CTROUGHB", "Plasma/Blood/Serum", "247",
      "CTROUGHD", "Conc Trough by Dose", "CTROUGHD", "Plasma/Blood/Serum", "248",
      "CTROUGHS", "Conc Trough by SA", "CTROUGHS", "Plasma/Blood/Serum", "249",
      "CTROUGHW", "Conc Trough by WT", "CTROUGHW", "Plasma/Blood/Serum", "250",
      "EFFHL", "Effective Half-Life", "EFFHL", "Plasma/Blood/Serum", "251",
      "ERINT", "Excret Rate from T1 to T2", "ERINT_T1_T2_UNIT", "Plasma/Blood/Serum", "252",
      "ERINTB", "Excret Rate from T1 to T2 Norm by BMI", "ERINTB_T1_T2_UNIT", "Plasma/Blood/Serum", "253",
      "ERINTD", "Excret Rate from T1 to T2 Norm by Dose", "ERINTD_T1_T2_UNIT", "Plasma/Blood/Serum", "254",
      "ERINTS", "Excret Rate from T1 to T2 Norm by SA", "ERINTS_T1_T2_UNIT", "Plasma/Blood/Serum", "255",
      "ERINTW", "Excret Rate from T1 to T2 Norm by WT", "ERINTW_T1_T2_UNIT", "Plasma/Blood/Serum", "256",
      "ERLSTB", "Last Meas Excretion Rate Norm by BMI", "ERLSTB", "Plasma/Blood/Serum", "257",
      "ERLSTD", "Last Meas Excretion Rate Norm by Dose", "ERLSTD", "Plasma/Blood/Serum", "258",
      "ERLSTS", "Last Meas Excretion Rate Norm by SA", "ERLSTS", "Plasma/Blood/Serum", "259",
      "ERLSTW", "Last Meas Excretion Rate Norm by WT", "ERLSTW", "Plasma/Blood/Serum", "260",
      "ERMAXB", "Max Excretion Rate Norm by BMI", "ERMAXB", "Plasma/Blood/Serum", "261",
      "ERMAXD", "Max Excretion Rate Norm by Dose", "ERMAXD", "Plasma/Blood/Serum", "262",
      "ERMAXS", "Max Excretion Rate Norm by SA", "ERMAXS", "Plasma/Blood/Serum", "263",
      "ERMAXW", "Max Excretion Rate Norm by WT", "ERMAXW", "Plasma/Blood/Serum", "264",
      "ERTLST", "Midpoint of Interval of Last Nonzero ER", "ERTLST", "Plasma/Blood/Serum", "265",
      "FABS", "Absolute Bioavailability", "FABS", "Plasma/Blood/Serum", "266",
      "FB", "Fraction Bound", "FB", "Plasma/Blood/Serum", "267",
      "FREL", "Relative Bioavailability", "FREL", "Plasma/Blood/Serum", "268",
      "FREXINT", "Fract Excr from T1 to T2", "FREXINT_T1_T2_UNIT", "Plasma/Blood/Serum", "269",
      "FU", "Fraction Unbound", "FU", "Plasma/Blood/Serum", "270",
      "HDCL", "Hemodialysis Clearance", "HDCL", "Plasma/Blood/Serum", "271",
      "HDER", "Hemodialysis Extraction Ratio", "HDER", "Plasma/Blood/Serum", "272",
      "HTMAX", "Half Tmax", "HTMAX", "Plasma/Blood/Serum", "273",
      "LAMZLTAU", "Lambda z Lower Limit TAU", "LAMZLTAU", "Plasma/Blood/Serum", "274",
      "LAMZNTAU", "Number of Points for Lambda z TAU", "LAMZNTAU", "Plasma/Blood/Serum", "275",
      "LAMZSPN", "Lambda z Span", "LAMZSPN", "Plasma/Blood/Serum", "276",
      "LAMZTAU", "Lambda z TAU", "LAMZTAU", "Plasma/Blood/Serum", "277",
      "LAMZUTAU", "Lambda z Upper Limit TAU", "LAMZUTAU", "Plasma/Blood/Serum", "278",
      "MAT", "Mean Absorption Time", "MAT", "Plasma/Blood/Serum", "279",
      "MRAUCIFO", "Metabolite Ratio for AUC Infinity Obs", "MRAUCIFO", "Plasma/Blood/Serum", "280",
      "MRAUCIFP", "Metabolite Ratio for AUC Infinity Pred", "MRAUCIFP", "Plasma/Blood/Serum", "281",
      "MRAUCINT", "Metabolite Ratio AUC from T1 to T2", "MRAUCINT_T1_T2_UNIT", "Plasma/Blood/Serum", "282",
      "MRAUCLST", "Metabolite Ratio AUC Last Nonzero Conc", "MRAUCLST", "Plasma/Blood/Serum", "283",
      "MRAUCTAU", "Metabolite Ratio for AUC Dosing Interval", "MRAUCTAU", "Plasma/Blood/Serum", "284",
      "MRCMAX", "Metabolite Ratio for Max Conc", "MRCMAX", "Plasma/Blood/Serum", "285",
      "MRTEVIFO", "MRT Extravasc Infinity Obs", "MRTEVIFO", "Plasma/Blood/Serum", "286",
      "MRTEVIFP", "MRT Extravasc Infinity Pred", "MRTEVIFP", "Plasma/Blood/Serum", "287",
      "MRTEVLST", "MRT Extravasc to Last Nonzero Conc", "MRTEVLST", "Plasma/Blood/Serum", "288",
      "MRTIVIFO", "MRT Intravasc Infinity Obs", "MRTIVIFO", "Plasma/Blood/Serum", "289",
      "MRTIVIFP", "MRT Intravasc Infinity Pred", "MRTIVIFP", "Plasma/Blood/Serum", "290",
      "MRTIVLST", "MRT Intravasc to Last Nonzero Conc", "MRTIVLST", "Plasma/Blood/Serum", "291",
      "NRENALCL", "Nonrenal CL", "NRENALCL", "Urine", "292",
      "NRENLCLB", "Nonrenal CL Norm by BMI", "NRENLCLB", "Urine", "293",
      "NRENLCLD", "Nonrenal CL Norm by Dose", "NRENLCLD", "Urine", "294",
      "NRENLCLS", "Nonrenal CL Norm by SA", "NRENLCLS", "Urine", "295",
      "NRENLCLW", "Nonrenal CL Norm by WT", "NRENLCLW", "Urine", "296",
      "PTROUGHR", "Peak Trough Ratio", "PTROUGHR", "Plasma/Blood/Serum", "297",
      "RAAUC", "Ratio AUC", "RAAUC", "Plasma/Blood/Serum", "298",
      "RAAUCIFO", "Ratio AUC Infinity Obs", "RAAUCIFO", "Plasma/Blood/Serum", "299",
      "RAAUCIFP", "Ratio AUC Infinity Pred", "RAAUCIFP", "Plasma/Blood/Serum", "300",
      "RACMAX", "Ratio CMAX", "RACMAX", "Plasma/Blood/Serum", "301",
      "RAMAXMIN", "Ratio of CMAX to CMIN", "RAMAXMIN", "Plasma/Blood/Serum", "302",
      "RCAMIFO", "Amt Rec Infinity Obs", "RCAMIFO", "Plasma/Blood/Serum", "303",
      "RCAMIFOB", "Amt Rec Infinity Obs Norm by BMI", "RCAMIFOB", "Plasma/Blood/Serum", "304",
      "RCAMIFOS", "Amt Rec Infinity Obs Norm by SA", "RCAMIFOS", "Plasma/Blood/Serum", "305",
      "RCAMIFOW", "Amt Rec Infinity Obs Norm by WT", "RCAMIFOW", "Plasma/Blood/Serum", "306",
      "RCAMIFP", "Amt Rec Infinity Pred", "RCAMIFP", "Plasma/Blood/Serum", "307",
      "RCAMIFPB", "Amt Rec Infinity Pred Norm by BMI", "RCAMIFPB", "Plasma/Blood/Serum", "308",
      "RCAMIFPS", "Amt Rec Infinity Pred Norm by SA", "RCAMIFPS", "Plasma/Blood/Serum", "309",
      "RCAMIFPW", "Amt Rec Infinity Pred Norm by WT", "RCAMIFPW", "Plasma/Blood/Serum", "310",
      "RCAMINTB", "Amt Rec from T1 to T2 Norm by BMI", "RCAMINTB_T1_T2_UNIT", "Plasma/Blood/Serum", "311",
      "RCAMINTS", "Amt Rec from T1 to T2 Norm by SA", "RCAMINTS_T1_T2_UNIT", "Plasma/Blood/Serum", "312",
      "RCAMINTW", "Amt Rec from T1 to T2 Norm by WT", "RCAMINTW_T1_T2_UNIT", "Plasma/Blood/Serum", "313",
      "RCAMTAU", "Amt Rec Over Dosing Interval", "RCAMTAU", "Plasma/Blood/Serum", "314",
      "RCAMTAUB", "Amt Rec Over Dosing Interval Norm by BMI", "RCAMTAUB", "Plasma/Blood/Serum", "315",
      "RCAMTAUS", "Amt Rec Over Dosing Interval Norm by SA", "RCAMTAUS", "Plasma/Blood/Serum", "316",
      "RCAMTAUW", "Amt Rec Over Dosing Interval Norm by WT", "RCAMTAUW", "Plasma/Blood/Serum", "317",
      "RCPCIFO", "Pct Rec Infinity Obs", "RCPCIFO", "Plasma/Blood/Serum", "318",
      "RCPCIFOB", "Pct Rec Infinity Obs Norm by BMI", "RCPCIFOB", "Plasma/Blood/Serum", "319",
      "RCPCIFOS", "Pct Rec Infinity Obs Norm by SA", "RCPCIFOS", "Plasma/Blood/Serum", "320",
      "RCPCIFOW", "Pct Rec Infinity Obs Norm by WT", "RCPCIFOW", "Plasma/Blood/Serum", "321",
      "RCPCIFP", "Pct Rec Infinity Pred", "RCPCIFP", "Plasma/Blood/Serum", "322",
      "RCPCIFPB", "Pct Rec Infinity Pred Norm by BMI", "RCPCIFPB", "Plasma/Blood/Serum", "323",
      "RCPCIFPS", "Pct Rec Infinity Pred Norm by SA", "RCPCIFPS", "Plasma/Blood/Serum", "324",
      "RCPCIFPW", "Pct Rec Infinity Pred Norm by WT", "RCPCIFPW", "Plasma/Blood/Serum", "325",
      "RCPCINTB", "Pct Rec from T1 to T2 Norm by BMI", "RCPCINTB_T1_T2_UNIT", "Plasma/Blood/Serum", "326",
      "RCPCINTS", "Pct Rec from T1 to T2 Norm by SA", "RCPCINTS_T1_T2_UNIT", "Plasma/Blood/Serum", "327",
      "RCPCINTW", "Pct Rec from T1 to T2 Norm by WT", "RCPCINTW_T1_T2_UNIT", "Plasma/Blood/Serum", "328",
      "RCPCLST", "Pct Rec to Last Nonzero Conc", "RCPCLST", "Plasma/Blood/Serum", "329",
      "RCPCTAU", "Pct Rec Over Dosing Interval", "RCPCTAU", "Plasma/Blood/Serum", "330",
      "RCPCTAUB", "Pct Rec Over Dosing Interval Norm by BMI", "RCPCTAUB", "Plasma/Blood/Serum", "331",
      "RCPCTAUS", "Pct Rec Over Dosing Interval Norm by SA", "RCPCTAUS", "Plasma/Blood/Serum", "332",
      "RCPCTAUW", "Pct Rec Over Dosing Interval Norm by WT", "RCPCTAUW", "Plasma/Blood/Serum", "333",
      "RENALCLB", "Renal CL Norm by BMI", "RENALCLB", "Urine", "334",
      "RENALCLD", "Renal CL Norm by Dose", "RENALCLD", "Urine", "335",
      "RENALCLS", "Renal CL Norm by SA", "RENALCLS", "Urine", "336",
      "RENALCLW", "Renal CL Norm by WT", "RENALCLW", "Urine", "337",
      "RENCLTAU", "Renal CL for Dose Int", "RENCLTAU", "Urine", "338",
      "RNCLINT", "Renal CL from T1 to T2", "RNCLINT_T1_T2_UNIT", "Urine", "339",
      "RNCLINTB", "Renal CL from T1 to T2 Norm by BMI", "RNCLINTB_T1_T2_UNIT", "Urine", "340",
      "RNCLINTD", "Renal CL from T1 to T2 Norm by Dose", "RNCLINTD_T1_T2_UNIT", "Urine", "341",
      "RNCLINTS", "Renal CL from T1 to T2 Norm by SA", "RNCLINTS_T1_T2_UNIT", "Urine", "342",
      "RNCLINTW", "Renal CL from T1 to T2 Norm by WT", "RNCLINTW_T1_T2_UNIT", "Urine", "343",
      "RNCLTAUB", "Renal CL for Dose Int Norm by BMI", "RNCLTAUB", "Urine", "344",
      "RNCLTAUD", "Renal CL for Dose Int Norm by Dose", "RNCLTAUD", "Urine", "345",
      "RNCLTAUS", "Renal CL for Dose Int Norm by SA", "RNCLTAUS", "Urine", "346",
      "RNCLTAUW", "Renal CL for Dose Int Norm by WT", "RNCLTAUW", "Urine", "347",
      "RNCLUB", "Renal CL for Unbound Drug", "RNCLUB", "Urine", "348",
      "SRAUC", "Stationarity Ratio AUC", "SRAUC", "Plasma/Blood/Serum", "349",
      "SWING", "Swing", "SWING", "Plasma/Blood/Serum", "350",
      "TAUHL", "Half-Life TAU", "TAUHL", "Plasma/Blood/Serum", "351",
      "TBBL", "Time Below Baseline", "Time_Below_B", "Plasma/Blood/Serum", "352",
      "TROUGHPR", "Trough Peak Ratio", "TROUGHPR", "Plasma/Blood/Serum", "353",
      "V0", "Vol Dist Initial", "V0", "Plasma/Blood/Serum", "354",
      "V0B", "Vol Dist Initial Norm by BMI", "V0B", "Plasma/Blood/Serum", "355",
      "V0D", "Vol Dist Initial Norm by Dose", "V0D", "Plasma/Blood/Serum", "356",
      "V0S", "Vol Dist Initial Norm by SA", "V0S", "Plasma/Blood/Serum", "357",
      "V0W", "Vol Dist Initial Norm by WT", "V0W", "Plasma/Blood/Serum", "358",
      "VSSOB", "Vol Dist Steady State Obs Norm by BMI", "VSSOB", "Plasma/Blood/Serum", "359",
      "VSSOBD", "Vol Dist Steady State Obs by B", "VSSOBD", "Plasma/Blood/Serum", "360",
      "VSSOD", "Vol Dist Steady State Obs Norm by Dose", "VSSOD", "Plasma/Blood/Serum", "361",
      "VSSOF", "Vol Dist Steady State Obs by F", "VSSOF", "Plasma/Blood/Serum", "362",
      "VSSOS", "Vol Dist Steady State Obs Norm by SA", "VSSOS", "Plasma/Blood/Serum", "363",
      "VSSOUB", "Vol Dist Steady State Obs by UB", "VSSOUB", "Plasma/Blood/Serum", "364",
      "VSSOW", "Vol Dist Steady State Obs Norm by WT", "VSSOW", "Plasma/Blood/Serum", "365",
      "VSSPB", "Vol Dist Steady State Pred Norm by BMI", "VSSPB", "Plasma/Blood/Serum", "366",
      "VSSPBD", "Vol Dist Steady State Pred by B", "VSSPBD", "Plasma/Blood/Serum", "367",
      "VSSPD", "Vol Dist Steady State Pred Norm by Dose", "VSSPD", "Plasma/Blood/Serum", "368",
      "VSSPF", "Vol Dist Steady State Pred by F", "VSSPF", "Plasma/Blood/Serum", "369",
      "VSSPS", "Vol Dist Steady State Pred Norm by SA", "VSSPS", "Plasma/Blood/Serum", "370",
      "VSSPUB", "Vol Dist Steady State Pred by UB", "VSSPUB", "Plasma/Blood/Serum", "371",
      "VSSPW", "Vol Dist Steady State Pred Norm by WT", "VSSPW", "Plasma/Blood/Serum", "372",
      "VZ", "Vol Z", "Vz", "Plasma/Blood/Serum", "373",
      "VZF", "Vol Z by F", "Vz_F", "Plasma/Blood/Serum", "374",
      "VZFOB", "Vz Obs by F Norm by BMI", "VZFOB", "Plasma/Blood/Serum", "375",
      "VZFOD", "Vz Obs by F Norm by Dose", "VZFOD", "Plasma/Blood/Serum", "376",
      "VZFOS", "Vz Obs by F Norm by SA", "VZFOS", "Plasma/Blood/Serum", "377",
      "VZFOUB", "Vz Obs by F for UB", "VZFOUB", "Plasma/Blood/Serum", "378",
      "VZFOW", "Vz Obs by F Norm by WT", "VZFOW", "Plasma/Blood/Serum", "379",
      "VZFPB", "Vz Pred by F Norm by BMI", "VZFPB", "Plasma/Blood/Serum", "380",
      "VZFPD", "Vz Pred by F Norm by Dose", "VZFPD", "Plasma/Blood/Serum", "381",
      "VZFPS", "Vz Pred by F Norm by SA", "VZFPS", "Plasma/Blood/Serum", "382",
      "VZFPUB", "Vz Pred by F for UB", "VZFPUB", "Plasma/Blood/Serum", "383",
      "VZFPW", "Vz Pred by F Norm by WT", "VZFPW", "Plasma/Blood/Serum", "384",
      "VZFTAU", "Vz for Dose Int by F", "VZFTAU", "Plasma/Blood/Serum", "385",
      "VZFTAUB", "Vz for Dose Int by F Norm by BMI", "VZFTAUB", "Plasma/Blood/Serum", "386",
      "VZFTAUD", "Vz for Dose Int by F Norm by Dose", "VZFTAUD", "Plasma/Blood/Serum", "387",
      "VZFTAUS", "Vz for Dose Int by F Norm by SA", "VZFTAUS", "Plasma/Blood/Serum", "388",
      "VZFTAUW", "Vz for Dose Int by F Norm by WT", "VZFTAUW", "Plasma/Blood/Serum", "389",
      "VZOB", "Vz Obs Norm by BMI", "VZOB", "Plasma/Blood/Serum", "390",
      "VZOD", "Vz Obs Norm by Dose", "VZOD", "Plasma/Blood/Serum", "391",
      "VZOS", "Vz Obs Norm by SA", "VZOS", "Plasma/Blood/Serum", "392",
      "VZOUB", "Vz Obs for UB", "VZOUB", "Plasma/Blood/Serum", "393",
      "VZOW", "Vz Obs Norm by WT", "VZOW", "Plasma/Blood/Serum", "394",
      "VZPB", "Vz Pred Norm by BMI", "VZPB", "Plasma/Blood/Serum", "395",
      "VZPD", "Vz Pred Norm by Dose", "VZPD", "Plasma/Blood/Serum", "396",
      "VZPS", "Vz Pred Norm by SA", "VZPS", "Plasma/Blood/Serum", "397",
      "VZPUB", "Vz Pred for UB", "VZPUB", "Plasma/Blood/Serum", "398"
    ),
    ncol = 5,
    byrow = TRUE
  ))
  colnames(pk_dataset) <- c("PARAMCD", "PARAM", "TLG_DISPLAY", "MATRIX", "TLG_ORDER")
  pk_dataset
}

#' Horizontal Waterfall Plot
#'
#' This basic waterfall plot visualizes a quantity \code{height} ordered by value with some
#' markup.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @param height (`numeric``)\cr vector containing values to be plotted as the waterfall bars.
#' @param id (`character`)\cr vector containing IDs to use as the x-axis label for the waterfall bars.
#' @param col (`character`)\cr colors.
#' @param col_var (`factor`, `character` or `NULL`)\cr categorical variable for bar coloring. `NULL` by default.
#' @param xlab (`character`)\cr x label. Default is `"ID"`.
#' @param ylab (`character`)\cr y label. Default is `"Value"`.
#' @param title (`character`)\cr text to be displayed as plot title.
#' @param col_legend_title (`character`)\cr text to be displayed as legend title.
#' @return (`ggplot` object)\cr waterfall plot.
#' @template author_song24
#'
#' @export
#'
#' @examples
#' library(dplyr)
#' library(nestcolor)
#'
#' g_waterfall(height = c(3, 5, -1), id = letters[1:3])
#'
#' g_waterfall(
#'   height = c(3, 5, -1),
#'   id = letters[1:3],
#'   col_var = letters[1:3]
#' )
#'
#' adsl_f <- tern_ex_adsl %>%
#'   select(USUBJID, STUDYID, ARM, ARMCD, SEX)
#'
#' adrs_f <- tern_ex_adrs %>%
#'   filter(PARAMCD == "OVRINV") %>%
#'   mutate(pchg = rnorm(n(), 10, 50))
#'
#' adrs_f <- head(adrs_f, 30)
#' adrs_f <- adrs_f[!duplicated(adrs_f$USUBJID), ]
#' head(adrs_f)
#'
#' g_waterfall(
#'   height = adrs_f$pchg,
#'   id = adrs_f$USUBJID,
#'   col_var = adrs_f$AVALC
#' )
#'
#' g_waterfall(
#'   height = adrs_f$pchg,
#'   id = paste("asdfdsfdsfsd", adrs_f$USUBJID),
#'   col_var = adrs_f$SEX
#' )
#'
#' g_waterfall(
#'   height = adrs_f$pchg,
#'   id = paste("asdfdsfdsfsd", adrs_f$USUBJID),
#'   xlab = "ID",
#'   ylab = "Percentage Change",
#'   title = "Waterfall plot"
#' )
g_waterfall <- function(height,
                        id,
                        col_var = NULL,
                        col = getOption("ggplot2.discrete.colour"),
                        xlab = NULL,
                        ylab = NULL,
                        col_legend_title = NULL,
                        title = NULL) {
  if (!is.null(col_var)) {
    check_same_n(height = height, id = id, col_var = col_var)
  } else {
    check_same_n(height = height, id = id)
  }

  checkmate::assert_multi_class(col_var, c("character", "factor"), null.ok = TRUE)
  checkmate::assert_character(col, null.ok = TRUE)

  xlabel <- deparse(substitute(id))
  ylabel <- deparse(substitute(height))

  col_label <- if (!missing(col_var)) {
    deparse(substitute(col_var))
  }

  xlab <- if (is.null(xlab)) xlabel else xlab
  ylab <- if (is.null(ylab)) ylabel else ylab
  col_legend_title <- if (is.null(col_legend_title)) col_label else col_legend_title

  plot_data <- data.frame(
    height = height,
    id = as.character(id),
    col_var = if (is.null(col_var)) "x" else to_n(col_var, length(height)),
    stringsAsFactors = FALSE
  )

  plot_data_ord <- plot_data[order(plot_data$height, decreasing = TRUE), ]

  p <- ggplot2::ggplot(plot_data_ord, ggplot2::aes(x = factor(id, levels = id), y = height)) +
    ggplot2::geom_col() +
    ggplot2::geom_text(
      label = format(plot_data_ord$height, digits = 2),
      vjust = ifelse(plot_data_ord$height >= 0, -0.5, 1.5)
    ) +
    ggplot2::xlab(xlab) +
    ggplot2::ylab(ylab) +
    ggplot2::theme(axis.text.x = ggplot2::element_text(angle = 90, hjust = 0, vjust = .5))

  if (!is.null(col_var)) {
    p <- p +
      ggplot2::aes(fill = col_var) +
      ggplot2::labs(fill = col_legend_title) +
      ggplot2::theme(
        legend.position = "bottom",
        legend.background = ggplot2::element_blank(),
        legend.title = ggplot2::element_text(face = "bold"),
        legend.box.background = ggplot2::element_rect(colour = "black")
      )
  }

  if (!is.null(col)) {
    p <- p +
      ggplot2::scale_fill_manual(values = col)
  }

  if (!is.null(title)) {
    p <- p +
      ggplot2::labs(title = title) +
      ggplot2::theme(plot.title = ggplot2::element_text(face = "bold"))
  }

  p
}

#' Estimation of Proportions
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Estimate the proportion of responders within a studied population.
#'
#' @inheritParams argument_convention
#' @seealso [h_proportions]
#'
#' @name estimate_proportions
#'
NULL

#' @describeIn estimate_proportions statistics function estimating a
#'   proportion along with its confidence interval.
#'
#' @inheritParams prop_strat_wilson
#' @param df (`logical` or `data.frame`)\cr if only a logical vector is used,
#'   it indicates whether each subject is a responder or not. `TRUE` represents
#'   a successful outcome. If a `data.frame` is provided, also the `strata` variable
#'   names must be provided in `variables` as a list element with the strata strings.
#'   In the case of `data.frame`, the logical vector of responses must be indicated as a
#'   variable name in `.var`.
#' @param method (`string`)\cr the method used to construct the confidence interval
#'   for proportion of successful outcomes; one of `waldcc`, `wald`, `clopper-pearson`,
#'   `wilson`, `wilsonc`, `strat_wilson`, `strat_wilsonc`, `agresti-coull` or `jeffreys`.
#' @param long (`flag`)\cr a long description is required.
#'
#' @examples
#' # Case with only logical vector.
#' rsp_v <- c(1, 0, 1, 0, 1, 1, 0, 0)
#' s_proportion(rsp_v)
#'
#' # Example for Stratified Wilson CI
#' nex <- 100 # Number of example rows
#' dta <- data.frame(
#'   "rsp" = sample(c(TRUE, FALSE), nex, TRUE),
#'   "grp" = sample(c("A", "B"), nex, TRUE),
#'   "f1" = sample(c("a1", "a2"), nex, TRUE),
#'   "f2" = sample(c("x", "y", "z"), nex, TRUE),
#'   stringsAsFactors = TRUE
#' )
#'
#' s_proportion(
#'   df = dta,
#'   .var = "rsp",
#'   variables = list(strata = c("f1", "f2")),
#'   conf_level = 0.90,
#'   method = "strat_wilson"
#' )
#'
#' @export
s_proportion <- function(df,
                         .var,
                         conf_level = 0.95,
                         method = c(
                           "waldcc", "wald", "clopper-pearson",
                           "wilson", "wilsonc", "strat_wilson", "strat_wilsonc",
                           "agresti-coull", "jeffreys"
                         ),
                         weights = NULL,
                         max_iterations = 50,
                         variables = list(strata = NULL),
                         long = FALSE) {
  method <- match.arg(method)
  checkmate::assert_flag(long)
  assert_proportion_value(conf_level)

  if (!is.null(variables$strata)) {
    # Checks for strata
    if (missing(df)) stop("When doing stratified analysis a data.frame with specific columns is needed.")
    strata_colnames <- variables$strata
    checkmate::assert_character(strata_colnames, null.ok = FALSE)
    strata_vars <- stats::setNames(as.list(strata_colnames), strata_colnames)
    assert_df_with_variables(df, strata_vars)

    strata <- interaction(df[strata_colnames])
    strata <- as.factor(strata)

    # Pushing down checks to prop_strat_wilson
  } else if (checkmate::test_subset(method, c("strat_wilson", "strat_wilsonc"))) {
    stop("To use stratified methods you need to specify the strata variables.")
  }
  if (checkmate::test_atomic_vector(df)) {
    rsp <- as.logical(df)
  } else {
    rsp <- as.logical(df[[.var]])
  }
  n <- sum(rsp)
  p_hat <- mean(rsp)

  prop_ci <- switch(method,
    "clopper-pearson" = prop_clopper_pearson(rsp, conf_level),
    "wilson" = prop_wilson(rsp, conf_level),
    "wilsonc" = prop_wilson(rsp, conf_level, correct = TRUE),
    "strat_wilson" = prop_strat_wilson(rsp,
      strata,
      weights,
      conf_level,
      max_iterations,
      correct = FALSE
    )$conf_int,
    "strat_wilsonc" = prop_strat_wilson(rsp,
      strata,
      weights,
      conf_level,
      max_iterations,
      correct = TRUE
    )$conf_int,
    "wald" = prop_wald(rsp, conf_level),
    "waldcc" = prop_wald(rsp, conf_level, correct = TRUE),
    "agresti-coull" = prop_agresti_coull(rsp, conf_level),
    "jeffreys" = prop_jeffreys(rsp, conf_level)
  )

  list(
    "n_prop" = formatters::with_label(c(n, p_hat), "Responders"),
    "prop_ci" = formatters::with_label(
      x = 100 * prop_ci, label = d_proportion(conf_level, method, long = long)
    )
  )
}

#' @describeIn estimate_proportions Formatted Analysis function which can be further customized by calling
#'   [rtables::make_afun()] on it. It is used as `afun` in [rtables::analyze()].
#'
#' @export
a_proportion <- make_afun(
  s_proportion,
  .formats = c(n_prop = "xx (xx.x%)", prop_ci = "(xx.x, xx.x)")
)

#' @describeIn estimate_proportions used in a `rtables` pipeline.
#' @inheritParams rtables::analyze
#' @param ... other arguments are ultimately conveyed to [s_proportion()].
#'
#' @examples
#' dta_test <- data.frame(
#'   USUBJID = paste0("S", 1:12),
#'   ARM     = rep(LETTERS[1:3], each = 4),
#'   AVAL    = c(A = c(1, 1, 1, 1), B = c(0, 0, 1, 1), C = c(0, 0, 0, 0))
#' )
#'
#' basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   estimate_proportion(vars = "AVAL") %>%
#'   build_table(df = dta_test)
#'
#' @export
estimate_proportion <- function(lyt,
                                vars,
                                ...,
                                show_labels = "hidden",
                                table_names = vars,
                                .stats = NULL,
                                .formats = NULL,
                                .labels = NULL,
                                .indent_mods = NULL) {
  afun <- make_afun(
    a_proportion,
    .stats = .stats,
    .formats = .formats,
    .labels = .labels,
    .indent_mods = .indent_mods
  )
  analyze(
    lyt,
    vars,
    afun = afun,
    extra_args = list(...),
    show_labels = show_labels,
    table_names = table_names
  )
}

#' Helper Functions for Calculating Proportion Confidence Intervals
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Functions to calculate different proportion confidence intervals for use in [estimate_proportion()].
#'
#' @inheritParams argument_convention
#' @inheritParams estimate_proportions
#' @seealso [estimate_proportions], descriptive function [d_proportion()],
#'  and helper functions [strata_normal_quantile()] and [update_weights_strat_wilson()].
#'
#' @name h_proportions
NULL

#' @describeIn h_proportions the Wilson interval calls [stats::prop.test()].
#'  Also referred to as Wilson score interval.
#'
#' @examples
#' rsp <- c(
#'   TRUE, TRUE, TRUE, TRUE, TRUE,
#'   FALSE, FALSE, FALSE, FALSE, FALSE
#' )
#' prop_wilson(rsp, conf_level = 0.9)
#'
#' @export
prop_wilson <- function(rsp, conf_level, correct = FALSE) {
  y <- stats::prop.test(
    sum(rsp),
    length(rsp),
    correct = correct,
    conf.level = conf_level
  )

  as.numeric(y$conf.int)
}

#' @describeIn h_proportions Calculates the stratified Wilson confidence
#'   interval for unequal proportions as described in
#'   \insertCite{Yan2010-jt;textual}{tern}
#'
#' @param strata (`factor`)\cr variable with one level per stratum and same length as `rsp`.
#' @param weights (`numeric` or `NULL`)\cr weights for each level of the strata. If `NULL`, they are
#'   estimated using the iterative algorithm proposed in \insertCite{Yan2010-jt;textual}{tern} that
#'   minimizes the weighted squared length of the confidence interval.
#' @param max_iterations (`count`)\cr maximum number of iterations for the iterative procedure used
#'   to find estimates of optimal weights.
#' @param correct (`flag`)\cr include the continuity correction. For further information, see for example
#'   [stats::prop.test()].
#'
#' @examples
#' # Stratified Wilson confidence interval with unequal probabilities
#'
#' set.seed(1)
#' rsp <- sample(c(TRUE, FALSE), 100, TRUE)
#' strata_data <- data.frame(
#'   "f1" = sample(c("a", "b"), 100, TRUE),
#'   "f2" = sample(c("x", "y", "z"), 100, TRUE),
#'   stringsAsFactors = TRUE
#' )
#' strata <- interaction(strata_data)
#' n_strata <- ncol(table(rsp, strata)) # Number of strata
#'
#' prop_strat_wilson(
#'   rsp = rsp, strata = strata,
#'   conf_level = 0.90
#' )
#'
#' # Not automatic setting of weights
#' prop_strat_wilson(
#'   rsp = rsp, strata = strata,
#'   weights = rep(1 / n_strata, n_strata),
#'   conf_level = 0.90
#' )
#' @references
#' - \insertRef{Yan2010-jt}{tern}
#'
#' @importFrom Rdpack reprompt
#'
#' @export
prop_strat_wilson <- function(rsp,
                              strata,
                              weights = NULL,
                              conf_level = 0.95,
                              max_iterations = NULL,
                              correct = FALSE) {
  checkmate::assert_logical(rsp, any.missing = FALSE)
  checkmate::assert_factor(strata, len = length(rsp))
  assert_proportion_value(conf_level)

  tbl <- table(rsp, strata)
  n_strata <- ncol(tbl)

  # Checking the weights and maximum number of iterations.
  do_iter <- FALSE
  if (is.null(weights)) {
    weights <- rep(1 / n_strata, n_strata) # Initialization for iterative procedure
    do_iter <- TRUE

    # Iteration parameters
    if (is.null(max_iterations)) max_iterations <- 10
    checkmate::assert_int(max_iterations, na.ok = FALSE, null.ok = FALSE, lower = 1)
  }
  checkmate::assert_numeric(weights, lower = 0, upper = 1, any.missing = FALSE, len = ncol(tbl))
  checkmate::assert_int(sum(weights), lower = 1, upper = 1)


  xs <- tbl["TRUE", ]
  ns <- colSums(tbl)
  use_stratum <- (ns > 0)
  ns <- ns[use_stratum]
  xs <- xs[use_stratum]
  ests <- xs / ns
  vars <- ests * (1 - ests) / ns

  strata_qnorm <- strata_normal_quantile(vars, weights, conf_level)

  # Iterative setting of weights if they were not set externally
  weights_new <- if (do_iter) {
    update_weights_strat_wilson(vars, strata_qnorm, weights, ns, max_iterations, conf_level)$weights
  } else {
    weights
  }

  strata_conf_level <- 2 * stats::pnorm(strata_qnorm) - 1

  ci_by_strata <- Map(
    function(x, n) {
      # Classic Wilson's confidence interval
      suppressWarnings(stats::prop.test(x, n, correct = correct, conf.level = strata_conf_level)$conf.int)
    },
    x = xs,
    n = ns
  )
  lower_by_strata <- sapply(ci_by_strata, "[", 1L)
  upper_by_strata <- sapply(ci_by_strata, "[", 2L)

  lower <- sum(weights_new * lower_by_strata)
  upper <- sum(weights_new * upper_by_strata)

  # Return values
  if (do_iter) {
    list(
      conf_int = c(
        lower = lower,
        upper = upper
      ),
      weights = weights_new
    )
  } else {
    list(
      conf_int = c(
        lower = lower,
        upper = upper
      )
    )
  }
}

#' @describeIn h_proportions the Clopper-Pearson interval calls
#'   [stats::binom.test()]. Also referred to as the `exact` method.
#'
#' @examples
#' prop_clopper_pearson(rsp, conf_level = .95)
#'
#' @export
prop_clopper_pearson <- function(rsp,
                                 conf_level) {
  y <- stats::binom.test(
    x = sum(rsp),
    n = length(rsp),
    conf.level = conf_level
  )
  as.numeric(y$conf.int)
}

#' @describeIn h_proportions the Wald interval follows the usual
#'   textbook definition for a single proportion confidence interval using the
#'   normal approximation.
#'
#' @param correct (`flag`)\cr apply continuity correction.
#'
#' @examples
#' prop_wald(rsp, conf_level = 0.95)
#' prop_wald(rsp, conf_level = 0.95, correct = TRUE)
#'
#' @export
prop_wald <- function(rsp, conf_level, correct = FALSE) {
  n <- length(rsp)
  p_hat <- mean(rsp)
  z <- stats::qnorm((1 + conf_level) / 2)
  q_hat <- 1 - p_hat
  correct <- if (correct) 1 / (2 * n) else 0

  err <- z * sqrt(p_hat * q_hat) / sqrt(n) + correct
  l_ci <- max(0, p_hat - err)
  u_ci <- min(1, p_hat + err)

  c(l_ci, u_ci)
}

#' @describeIn h_proportions the Agresti-Coull interval was created by
#'   Alan Agresti and Brent Coull and can be understood (for 95% CI) as adding
#'   two successes and two failures to the data, and then using the Wald
#'   formula to construct a CI.
#'
#' @examples
#' prop_agresti_coull(rsp, conf_level = 0.95)
#'
#' @export
prop_agresti_coull <- function(rsp, conf_level) {
  n <- length(rsp)
  x_sum <- sum(rsp)
  z <- stats::qnorm((1 + conf_level) / 2)

  # Add here both z^2 / 2 successes and failures.
  x_sum_tilde <- x_sum + z^2 / 2
  n_tilde <- n + z^2

  # Then proceed as with the Wald interval.
  p_tilde <- x_sum_tilde / n_tilde
  q_tilde <- 1 - p_tilde
  err <- z * sqrt(p_tilde * q_tilde) / sqrt(n_tilde)
  l_ci <- max(0, p_tilde - err)
  u_ci <- min(1, p_tilde + err)

  c(l_ci, u_ci)
}

#' @describeIn h_proportions the Jeffreys interval is an equal-tailed
#'   interval based on the non-informative Jeffreys prior for a binomial
#'   proportion.
#'
#' @examples
#' prop_jeffreys(rsp, conf_level = 0.95)
#'
#' @export
prop_jeffreys <- function(rsp,
                          conf_level) {
  n <- length(rsp)
  x_sum <- sum(rsp)

  alpha <- 1 - conf_level
  l_ci <- ifelse(
    x_sum == 0,
    0,
    stats::qbeta(alpha / 2, x_sum + 0.5, n - x_sum + 0.5)
  )

  u_ci <- ifelse(
    x_sum == n,
    1,
    stats::qbeta(1 - alpha / 2, x_sum + 0.5, n - x_sum + 0.5)
  )

  c(l_ci, u_ci)
}

#' Description of the Proportion Summary
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This is a helper function that describes the analysis in [s_proportion()].
#'
#' @inheritParams s_proportion
#' @param long (`flag`)\cr whether a long or a short (default) description is required.
#'
#' @return String describing the analysis.
#'
#' @export
d_proportion <- function(conf_level,
                         method,
                         long = FALSE) {
  label <- paste0(conf_level * 100, "% CI")

  if (long) label <- paste(label, "for Response Rates")

  method_part <- switch(method,
    "clopper-pearson" = "Clopper-Pearson",
    "waldcc" = "Wald, with correction",
    "wald" = "Wald, without correction",
    "wilson" = "Wilson, without correction",
    "strat_wilson" = "Stratified Wilson, without correction",
    "wilsonc" = "Wilson, with correction",
    "strat_wilsonc" = "Stratified Wilson, with correction",
    "agresti-coull" = "Agresti-Coull",
    "jeffreys" = "Jeffreys",
    stop(paste(method, "does not have a description"))
  )

  paste0(label, " (", method_part, ")")
}

#' Helper Function for the Estimation of Stratified Quantiles
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This function wraps the estimation of stratified percentiles when we assume
#' the approximation for large numbers. This is necessary only in the case
#' proportions for each strata are unequal.
#'
#' @inheritParams argument_convention
#' @inheritParams prop_strat_wilson
#'
#' @seealso [prop_strat_wilson()]
#'
#' @examples
#' strata_data <- table(data.frame(
#'   "f1" = sample(c(TRUE, FALSE), 100, TRUE),
#'   "f2" = sample(c("x", "y", "z"), 100, TRUE),
#'   stringsAsFactors = TRUE
#' ))
#' ns <- colSums(strata_data)
#' ests <- strata_data["TRUE", ] / ns
#' vars <- ests * (1 - ests) / ns
#' weights <- rep(1 / length(ns), length(ns))
#' strata_normal_quantile(vars, weights, 0.95)
#'
#' @export
strata_normal_quantile <- function(vars, weights, conf_level) {
  summands <- weights^2 * vars
  # Stratified quantile
  sqrt(sum(summands)) / sum(sqrt(summands)) * stats::qnorm((1 + conf_level) / 2)
}

#' Helper Function for the Estimation of Weights for `prop_strat_wilson`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This function wraps the iteration procedure that allows you to estimate
#' the weights for each proportional strata. This assumes to minimize the
#' weighted squared length of the confidence interval.
#'
#' @inheritParams prop_strat_wilson
#' @param vars (`numeric`)\cr normalized proportions for each strata.
#' @param strata_qnorm (`numeric`)\cr initial estimation with identical weights of the quantiles.
#' @param initial_weights (`numeric`)\cr initial weights used to calculate `strata_qnorm`. This can
#'   be optimized in the future if we need to estimate better initial weights.
#' @param n_per_strata (`numeric`)\cr number of elements in each strata.
#' @param max_iterations (`count`)\cr maximum number of iterations to be tried. Convergence is always checked.
#' @param tol (`number`)\cr tolerance threshold for convergence.
#'
#' @seealso For references and details see [prop_strat_wilson()].
#'
#' @examples
#' vs <- c(0.011, 0.013, 0.012, 0.014, 0.017, 0.018)
#' sq <- 0.674
#' ws <- rep(1 / length(vs), length(vs))
#' ns <- c(22, 18, 17, 17, 14, 12)
#'
#' update_weights_strat_wilson(vs, sq, ws, ns, 100, 0.95, 0.001)
#'
#' @export
update_weights_strat_wilson <- function(vars,
                                        strata_qnorm,
                                        initial_weights,
                                        n_per_strata,
                                        max_iterations = 50,
                                        conf_level = 0.95,
                                        tol = 0.001) {
  it <- 0
  diff_v <- NULL

  while (it < max_iterations) {
    it <- it + 1
    weights_new_t <- (1 + strata_qnorm^2 / n_per_strata)^2
    weights_new_b <- (vars + strata_qnorm^2 / (4 * n_per_strata^2))
    weights_new <- weights_new_t / weights_new_b
    weights_new <- weights_new / sum(weights_new)
    strata_qnorm <- strata_normal_quantile(vars, weights_new, conf_level)
    diff_v <- c(diff_v, sum(abs(weights_new - initial_weights)))
    if (diff_v[length(diff_v)] < tol) break
    initial_weights <- weights_new
  }

  if (it == max_iterations) {
    warning("The heuristic to find weights did not converge with max_iterations = ", max_iterations)
  }

  list(
    "n_it" = it,
    "weights" = weights_new,
    "diff_v" = diff_v
  )
}

#' Tabulate Survival Duration by Subgroup
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Tabulate statistics such as median survival time and hazard ratio for population subgroups.
#'
#' @details These functions create a layout starting from a data frame which contains
#'   the required statistics. Tables typically used as part of forest plot.
#'
#' @inheritParams argument_convention
#' @inheritParams survival_coxph_pairwise
#' @param data (`data.frame`)\cr the dataset containing the variables to summarize.
#' @param groups_lists (named `list` of `list`)\cr optionally contains for each `subgroups` variable a
#'   list, which specifies the new group levels via the names and the
#'   levels that belong to it in the character vectors that are elements of the list.
#' @param label_all (`string`)\cr label for the total population analysis.
#' @param time_unit (`string`)\cr label with unit of median survival time. Default `NULL` skips
#'   displaying unit.
#' @name survival_duration_subgroups
#' @seealso [extract_survival_subgroups()]
#'
#' @examples
#' library(dplyr)
#' library(forcats)
#'
#' adtte <- tern_ex_adtte
#'
#' # Save variable labels before data processing steps.
#' adtte_labels <- formatters::var_labels(adtte)
#'
#' adtte_f <- adtte %>%
#'   filter(
#'     PARAMCD == "OS",
#'     ARM %in% c("B: Placebo", "A: Drug X"),
#'     SEX %in% c("M", "F")
#'   ) %>%
#'   mutate(
#'     # Reorder levels of ARM to display reference arm before treatment arm.
#'     ARM = droplevels(fct_relevel(ARM, "B: Placebo")),
#'     SEX = droplevels(SEX),
#'     AVALU = as.character(AVALU),
#'     is_event = CNSR == 0
#'   )
#' labels <- c(
#'   "ARM" = adtte_labels[["ARM"]],
#'   "SEX" = adtte_labels[["SEX"]],
#'   "AVALU" = adtte_labels[["AVALU"]],
#'   "is_event" = "Event Flag"
#' )
#' formatters::var_labels(adtte_f)[names(labels)] <- labels
#'
#' df <- extract_survival_subgroups(
#'   variables = list(
#'     tte = "AVAL",
#'     is_event = "is_event",
#'     arm = "ARM", subgroups = c("SEX", "BMRKR2")
#'   ),
#'   data = adtte_f
#' )
#' df
NULL

#' Prepares Survival Data for Population Subgroups in Data Frames
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Prepares estimates of median survival times and treatment hazard ratios for population subgroups in
#' data frames. Simple wrapper for [h_survtime_subgroups_df()] and [h_coxph_subgroups_df()].
#'   Result is a list of two data frames: `survtime` and `hr`.
#'   `variables` corresponds to the names of variables found in `data`, passed as a named list and requires elements
#'   `tte`, `is_event`, `arm` and optionally `subgroups` and `strat`. `groups_lists` optionally specifies
#'   groupings for `subgroups` variables.
#' @export
#' @seealso [survival_duration_subgroups]
#' @inheritParams argument_convention
#' @inheritParams survival_duration_subgroups
#' @inheritParams survival_coxph_pairwise
#'
#' @examples
#' library(dplyr)
#' library(forcats)
#'
#' adtte <- tern_ex_adtte
#' adtte_labels <- formatters::var_labels(adtte)
#'
#' adtte_f <- adtte %>%
#'   filter(
#'     PARAMCD == "OS",
#'     ARM %in% c("B: Placebo", "A: Drug X"),
#'     SEX %in% c("M", "F")
#'   ) %>%
#'   mutate(
#'     # Reorder levels of ARM to display reference arm before treatment arm.
#'     ARM = droplevels(fct_relevel(ARM, "B: Placebo")),
#'     SEX = droplevels(SEX),
#'     AVALU = as.character(AVALU),
#'     is_event = CNSR == 0
#'   )
#' labels <- c(
#'   "ARM" = adtte_labels[["ARM"]],
#'   "SEX" = adtte_labels[["SEX"]],
#'   "AVALU" = adtte_labels[["AVALU"]],
#'   "is_event" = "Event Flag"
#' )
#' formatters::var_labels(adtte_f)[names(labels)] <- labels
#'
#' df <- extract_survival_subgroups(
#'   variables = list(
#'     tte = "AVAL",
#'     is_event = "is_event",
#'     arm = "ARM", subgroups = c("SEX", "BMRKR2")
#'   ),
#'   data = adtte_f
#' )
#' df
#'
#' df_grouped <- extract_survival_subgroups(
#'   variables = list(
#'     tte = "AVAL",
#'     is_event = "is_event",
#'     arm = "ARM", subgroups = c("SEX", "BMRKR2")
#'   ),
#'   data = adtte_f,
#'   groups_lists = list(
#'     BMRKR2 = list(
#'       "low" = "LOW",
#'       "low/medium" = c("LOW", "MEDIUM"),
#'       "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
#'     )
#'   )
#' )
#' df_grouped
extract_survival_subgroups <- function(variables,
                                       data,
                                       groups_lists = list(),
                                       control = control_coxph(),
                                       label_all = "All Patients") {
  df_survtime <- h_survtime_subgroups_df(
    variables,
    data,
    groups_lists = groups_lists,
    label_all = label_all
  )
  df_hr <- h_coxph_subgroups_df(
    variables,
    data,
    groups_lists = groups_lists,
    control = control,
    label_all = label_all
  )

  list(survtime = df_survtime, hr = df_hr)
}

#' @describeIn survival_duration_subgroups Formatted Analysis function used to format the results of
#'   [extract_survival_subgroups()]. Returns is a list of Formatted Analysis functions with one element per statistic.
#'
#' @examples
#' # Internal function - a_survival_subgroups
#' \dontrun{
#' a_survival_subgroups(.formats = list("n" = "xx", "median" = "xx.xx"))
#' }
#'
#' @keywords internal
a_survival_subgroups <- function(.formats = list(
                                   n = "xx",
                                   n_events = "xx",
                                   n_tot_events = "xx",
                                   median = "xx.x",
                                   n_tot = "xx",
                                   hr = list(format_extreme_values(2L)),
                                   ci = list(format_extreme_values_ci(2L)),
                                   pval = "x.xxxx | (<0.0001)"
                                 )) {
  checkmate::assert_list(.formats)
  checkmate::assert_subset(
    names(.formats),
    c("n", "n_events", "median", "n_tot", "n_tot_events", "hr", "ci", "pval")
  )

  afun_lst <- Map(
    function(stat, fmt) {
      if (stat == "ci") {
        function(df, labelstr = "", ...) {
          in_rows(
            .list = combine_vectors(df$lcl, df$ucl),
            .labels = as.character(df$subgroup),
            .formats = fmt
          )
        }
      } else {
        function(df, labelstr = "", ...) {
          in_rows(
            .list = as.list(df[[stat]]),
            .labels = as.character(df$subgroup),
            .formats = fmt
          )
        }
      }
    },
    stat = names(.formats),
    fmt = .formats
  )

  afun_lst
}

#' @describeIn survival_duration_subgroups table creating function.
#' @param df (`list`)\cr of data frames containing all analysis variables. List should be
#'   created using [extract_survival_subgroups()].
#' @param vars (`character`)\cr the name of statistics to be reported among
#'  `n_tot_events` (total number of events per group),
#'  `n_events` (number of events per group),
#'  `n_tot` (total number of observations per group),
#'  `n` (number of observations per group),
#'  `median` (median survival time),
#'  `hr` (hazard ratio),
#'  `ci` (confidence interval of hazard ratio) and
#'  `pval` (p value of the effect).
#'  Note, one of the statistics `n_tot` and `n_tot_events`, as well as both `hr` and `ci`
#'  are required.
#' @export
#' @examples
#'
#' ## Table with default columns.
#' basic_table() %>%
#'   tabulate_survival_subgroups(df, time_unit = adtte_f$AVALU[1])
#'
#' ## Table with a manually chosen set of columns: adding "pval".
#' basic_table() %>%
#'   tabulate_survival_subgroups(
#'     df = df,
#'     vars = c("n_tot_events", "n_events", "median", "hr", "ci", "pval"),
#'     time_unit = adtte_f$AVALU[1]
#'   )
tabulate_survival_subgroups <- function(lyt,
                                        df,
                                        vars = c("n_tot_events", "n_events", "median", "hr", "ci"),
                                        time_unit = NULL) {
  conf_level <- df$hr$conf_level[1]
  method <- df$hr$pval_label[1]

  afun_lst <- a_survival_subgroups()
  colvars <- d_survival_subgroups_colvars(
    vars,
    conf_level = conf_level,
    method = method,
    time_unit = time_unit
  )

  colvars_survtime <- list(
    vars = colvars$vars[names(colvars$labels) %in% c("n", "n_events", "median")],
    labels = colvars$labels[names(colvars$labels) %in% c("n", "n_events", "median")]
  )
  colvars_hr <- list(
    vars = colvars$vars[names(colvars$labels) %in% c("n_tot", "n_tot_events", "hr", "ci", "pval")],
    labels = colvars$labels[names(colvars$labels) %in% c("n_tot", "n_tot_events", "hr", "ci", "pval")]
  )

  # Columns from table_survtime are optional.
  if (length(colvars_survtime$vars) > 0) {
    lyt_survtime <- split_cols_by(lyt = lyt, var = "arm")
    lyt_survtime <- split_rows_by(
      lyt = lyt_survtime,
      var = "row_type",
      split_fun = keep_split_levels("content"),
      nested = FALSE
    )
    lyt_survtime <- summarize_row_groups(
      lyt = lyt_survtime,
      var = "var_label",
      cfun = afun_lst[names(colvars_survtime$labels)]
    )
    lyt_survtime <- split_cols_by_multivar(
      lyt = lyt_survtime,
      vars = colvars_survtime$vars,
      varlabels = colvars_survtime$labels
    )

    if ("analysis" %in% df$survtime$row_type) {
      lyt_survtime <- split_rows_by(
        lyt = lyt_survtime,
        var = "row_type",
        split_fun = keep_split_levels("analysis"),
        nested = FALSE,
        child_labels = "hidden"
      )
      lyt_survtime <- split_rows_by(lyt = lyt_survtime, var = "var_label", nested = TRUE)
      lyt_survtime <- analyze_colvars(
        lyt = lyt_survtime,
        afun = afun_lst[names(colvars_survtime$labels)],
        inclNAs = TRUE
      )
    }

    table_survtime <- build_table(lyt_survtime, df = df$survtime)
  } else {
    table_survtime <- NULL
  }

  # Columns "n_tot_events" or "n_tot", and "hr", "ci" in table_hr are required.
  lyt_hr <- split_cols_by(lyt = lyt, var = "arm")
  lyt_hr <- split_rows_by(
    lyt = lyt_hr,
    var = "row_type",
    split_fun = keep_split_levels("content"),
    nested = FALSE
  )
  lyt_hr <- summarize_row_groups(
    lyt = lyt_hr,
    var = "var_label",
    cfun = afun_lst[names(colvars_hr$labels)]
  )
  lyt_hr <- split_cols_by_multivar(
    lyt = lyt_hr,
    vars = colvars_hr$vars,
    varlabels = colvars_hr$labels
  ) %>%
    append_topleft("Baseline Risk Factors")

  if ("analysis" %in% df$survtime$row_type) {
    lyt_hr <- split_rows_by(
      lyt = lyt_hr,
      var = "row_type",
      split_fun = keep_split_levels("analysis"),
      nested = FALSE,
      child_labels = "hidden"
    )
    lyt_hr <- split_rows_by(lyt = lyt_hr, var = "var_label", nested = TRUE)
    lyt_hr <- analyze_colvars(
      lyt = lyt_hr,
      afun = afun_lst[names(colvars_hr$labels)],
      inclNAs = TRUE
    )
  }
  table_hr <- build_table(lyt_hr, df = df$hr)

  # There can be one or two vars starting with "n_tot".
  n_tot_ids <- grep("^n_tot", colvars_hr$vars)
  if (is.null(table_survtime)) {
    result <- table_hr
    hr_id <- match("hr", colvars_hr$vars)
    ci_id <- match("lcl", colvars_hr$vars)
  } else {
    # Reorder the table.
    result <- cbind_rtables(table_hr[, n_tot_ids], table_survtime, table_hr[, -n_tot_ids])
    # And then calculate column indices accordingly.
    hr_id <- length(n_tot_ids) + ncol(table_survtime) + match("hr", colvars_hr$vars[-n_tot_ids])
    ci_id <- length(n_tot_ids) + ncol(table_survtime) + match("lcl", colvars_hr$vars[-n_tot_ids])
    n_tot_ids <- seq_along(n_tot_ids)
  }

  structure(
    result,
    forest_header = paste0(rev(levels(df$survtime$arm)), "\nBetter"),
    col_x = hr_id,
    col_ci = ci_id,
    # Take the first one for scaling the symbol sizes in graph.
    col_symbol_size = n_tot_ids[1]
  )
}

#' Labels for Column Variables in Survival Duration by Subgroup Table
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Internal function to check variables included in
#' [tabulate_survival_subgroups()] and create column labels.
#' Note that at least one of `n_tot` and `n_tot_events` needs to be provided in `vars`.
#'
#' @inheritParams tabulate_survival_subgroups
#' @inheritParams argument_convention
#' @param method p-value method for testing hazard ratio = 1.
#' @return `list` of variables to tabulate and their labels.
#'
#' @export
d_survival_subgroups_colvars <- function(vars,
                                         conf_level,
                                         method,
                                         time_unit = NULL) {
  checkmate::assert_character(vars)
  checkmate::assert_string(time_unit, null.ok = TRUE)
  checkmate::assert_subset(c("hr", "ci"), vars)
  checkmate::assert_true(any(c("n_tot", "n_tot_events") %in% vars))
  checkmate::assert_subset(
    vars,
    c("n", "n_events", "median", "n_tot", "n_tot_events", "hr", "ci", "pval")
  )

  propcase_time_label <- if (!is.null(time_unit)) {
    paste0("Median (", time_unit, ")")
  } else {
    "Median"
  }

  varlabels <- c(
    n = "n",
    n_events = "Events",
    median = propcase_time_label,
    n_tot = "Total n",
    n_tot_events = "Total Events",
    hr = "Hazard Ratio",
    ci = paste0(100 * conf_level, "% Wald CI"),
    pval = method
  )

  colvars <- vars

  # The `lcl` variable is just a placeholder available in the analysis data,
  # it is not acutally used in the tabulation.
  # Variables used in the tabulation are lcl and ucl, see `a_survival_subgroups` for details.
  colvars[colvars == "ci"] <- "lcl"

  list(
    vars = colvars,
    labels = varlabels[vars]
  )
}

#' Difference Test for Two Proportions
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Various tests were implemented to test the difference between two
#' proportions.
#'
#' @param tbl (`matrix`)\cr matrix with two groups in rows and the binary response
#'   (`TRUE`/`FALSE`) in columns.
#' @seealso [h_prop_diff_test]
#'
#' @name prop_diff_test
#'
NULL

#' @describeIn prop_diff_test Statistics function which tests the difference
#'  between two proportions.
#'
#' @inheritParams argument_convention
#' @param method (`string`)\cr one of `chisq`, `cmh`, `fisher`, or `schouten`; specifies the test used
#'   to calculate the p-value.
#'
#' @return Named `list` with a single item `pval` with an attribute `label`
#'   describing the method used. The p-value tests the null hypothesis that
#'   proportions in two groups are the same.
#'
#' @examples
#'
#' # Statistics function
#' dta <- data.frame(
#'   rsp = sample(c(TRUE, FALSE), 100, TRUE),
#'   grp = factor(rep(c("A", "B"), each = 50)),
#'   strat = factor(rep(c("V", "W", "X", "Y", "Z"), each = 20))
#' )
#'
#' # Internal function - s_test_proportion_diff
#' \dontrun{
#' s_test_proportion_diff(
#'   df = subset(dta, grp == "A"),
#'   .var = "rsp",
#'   .ref_group = subset(dta, grp == "B"),
#'   .in_ref_col = FALSE,
#'   variables = list(strata = "strat"),
#'   method = "cmh"
#' )
#' }
#'
#' @keywords internal
s_test_proportion_diff <- function(df,
                                   .var,
                                   .ref_group,
                                   .in_ref_col,
                                   variables = list(strata = NULL),
                                   method = c("chisq", "schouten", "fisher", "cmh")) {
  method <- match.arg(method)
  y <- list(pval = "")

  if (!.in_ref_col) {
    assert_df_with_variables(df, list(rsp = .var))
    assert_df_with_variables(.ref_group, list(rsp = .var))
    rsp <- factor(
      c(.ref_group[[.var]], df[[.var]]),
      levels = c("TRUE", "FALSE")
    )
    grp <- factor(
      rep(c("ref", "Not-ref"), c(nrow(.ref_group), nrow(df))),
      levels = c("ref", "Not-ref")
    )

    if (!is.null(variables$strata) || method == "cmh") {
      strata <- variables$strata
      checkmate::assert_false(is.null(strata))
      strata_vars <- stats::setNames(as.list(strata), strata)
      assert_df_with_variables(df, strata_vars)
      assert_df_with_variables(.ref_group, strata_vars)
      strata <- c(interaction(.ref_group[strata]), interaction(df[strata]))
    }

    tbl <- switch(method,
      cmh = table(grp, rsp, strata),
      table(grp, rsp)
    )

    y$pval <- switch(method,
      chisq = prop_chisq(tbl),
      cmh = prop_cmh(tbl),
      fisher = prop_fisher(tbl),
      schouten = prop_schouten(tbl)
    )
  }

  y$pval <- formatters::with_label(y$pval, d_test_proportion_diff(method))
  y
}

#' Description of the Difference Test Between Two Proportions
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This is an auxiliary function that describes the analysis in
#' `s_test_proportion_diff`.
#'
#' @inheritParams s_test_proportion_diff
#' @return `string` describing the test from which the p-value is derived.
#'
#' @export
d_test_proportion_diff <- function(method) {
  checkmate::assert_string(method)
  meth_part <- switch(method,
    "schouten" = "Chi-Squared Test with Schouten Correction",
    "chisq" = "Chi-Squared Test",
    "cmh" = "Cochran-Mantel-Haenszel Test",
    "fisher" = "Fisher's Exact Test",
    stop(paste(method, "does not have a description"))
  )
  paste0("p-value (", meth_part, ")")
}

#' @describeIn prop_diff_test Formatted Analysis function which can be further customized by calling
#'   [rtables::make_afun()] on it. It is used as `afun` in [rtables::analyze()].
#'
#' @examples
#' # Internal function - a_test_proportion_diff
#' \dontrun{
#' a_test_proportion_diff(
#'   df = subset(dta, grp == "A"),
#'   .var = "rsp",
#'   .ref_group = subset(dta, grp == "B"),
#'   .in_ref_col = FALSE,
#'   variables = list(strata = "strat"),
#'   method = "cmh"
#' )
#' }
#'
#' @keywords internal
a_test_proportion_diff <- make_afun(
  s_test_proportion_diff,
  .formats = c(pval = "x.xxxx | (<0.0001)"),
  .indent_mods = c(pval = 1L)
)

#' @describeIn prop_diff_test Layout creating function which can be used for
#'   creating tables, which can take statistics function arguments and
#'   additional format arguments.
#' @param ... other arguments are passed to [s_test_proportion_diff()].
#' @inheritParams argument_convention
#' @export
#'
#' @examples
#' # With `rtables` pipelines.
#' l <- basic_table() %>%
#'   split_cols_by(var = "grp", ref_group = "B") %>%
#'   test_proportion_diff(
#'     vars = "rsp",
#'     method = "cmh", variables = list(strata = "strat")
#'   )
#'
#' build_table(l, df = dta)
test_proportion_diff <- function(lyt,
                                 vars,
                                 ...,
                                 var_labels = vars,
                                 show_labels = "hidden",
                                 table_names = vars,
                                 .stats = NULL,
                                 .formats = NULL,
                                 .labels = NULL,
                                 .indent_mods = NULL) {
  afun <- make_afun(
    a_test_proportion_diff,
    .stats = .stats,
    .formats = .formats,
    .labels = .labels,
    .indent_mods = .indent_mods
  )
  analyze(
    lyt,
    vars,
    afun = afun,
    var_labels = var_labels,
    extra_args = list(...),
    show_labels = show_labels,
    table_names = table_names
  )
}

#' Helper Functions to Test Proportion Differences
#'
#' Helper functions to implement various tests on the difference between two
#' proportions.
#'
#' @param tbl (`matrix`)\cr matrix with two groups in rows and the binary response
#'   (`TRUE`/`FALSE`) in columns.
#'
#' @seealso [prop_diff_test())] for implementation of these helper functions.
#'
#' @name h_prop_diff_test
NULL

#' @describeIn h_prop_diff_test performs Chi-Squared test.
#'   Internally calls [stats::prop.test()].
#'
#' @examples
#' # Non-stratified proportion difference test
#'
#' ## Data
#' A <- 20
#' B <- 20
#' set.seed(1)
#' rsp <- c(
#'   sample(c(TRUE, FALSE), size = A, prob = c(3 / 4, 1 / 4), replace = TRUE),
#'   sample(c(TRUE, FALSE), size = A, prob = c(1 / 2, 1 / 2), replace = TRUE)
#' )
#' grp <- c(rep("A", A), rep("B", B))
#' tbl <- table(grp, rsp)
#'
#' ## Chi-Squared test
#' # Internal function - prop_chisq
#' \dontrun{
#' prop_chisq(tbl)
#' }
#'
#' @keywords internal
prop_chisq <- function(tbl) {
  checkmate::assert_integer(c(ncol(tbl), nrow(tbl)), lower = 2, upper = 2)
  tbl <- tbl[, c("TRUE", "FALSE")]
  if (any(colSums(tbl) == 0)) {
    return(1)
  }
  stats::prop.test(tbl, correct = FALSE)$p.value
}

#' @describeIn h_prop_diff_test performs stratified Cochran-Mantel-Haenszel test.
#'   Internally calls [stats::mantelhaen.test()]. Note that strata with less than two observations
#'   are automatically discarded.
#'
#' @param ary (`array`, 3 dimensions)\cr array with two groups in rows, the binary response
#'   (`TRUE`/`FALSE`) in columns, and the strata in the third dimension.
#'
#' @examples
#' # Stratified proportion difference test
#'
#' ## Data
#' rsp <- sample(c(TRUE, FALSE), 100, TRUE)
#' grp <- factor(rep(c("A", "B"), each = 50))
#' strata <- factor(rep(c("V", "W", "X", "Y", "Z"), each = 20))
#' tbl <- table(grp, rsp, strata)
#'
#' ## Cochran-Mantel-Haenszel test
#' # Internal function - prop_cmh
#' \dontrun{
#' prop_cmh(tbl)
#' }
#'
#' @keywords internal
prop_cmh <- function(ary) {
  checkmate::assert_array(ary)
  checkmate::assert_integer(c(ncol(ary), nrow(ary)), lower = 2, upper = 2)
  checkmate::assert_integer(length(dim(ary)), lower = 3, upper = 3)
  strata_sizes <- apply(ary, MARGIN = 3, sum)
  if (any(strata_sizes < 5)) {
    warning("<5 data points in some strata. CMH test may be incorrect.")
    ary <- ary[, , strata_sizes > 1]
  }

  stats::mantelhaen.test(ary, correct = FALSE)$p.value
}

#' @describeIn h_prop_diff_test performs the Chi-Squared test with Schouten
#'   correction.
#'
#' @seealso For information on the Schouten correction (Schouten, 1980),
#'   visit https://onlinelibrary.wiley.com/doi/abs/10.1002/bimj.4710220305.
#'
#' @examples
#' ## Chi-Squared test + Schouten correction.
#' # Internal function - prop_schouten
#' \dontrun{
#' prop_schouten(tbl)
#' }
#'
#' @keywords internal
prop_schouten <- function(tbl) {
  checkmate::assert_integer(c(ncol(tbl), nrow(tbl)), lower = 2, upper = 2)
  tbl <- tbl[, c("TRUE", "FALSE")]
  if (any(colSums(tbl) == 0)) {
    return(1)
  }

  n <- sum(tbl)
  n1 <- sum(tbl[1, ])
  n2 <- sum(tbl[2, ])

  ad <- diag(tbl)
  bc <- diag(apply(tbl, 2, rev))
  ac <- tbl[, 1]
  bd <- tbl[, 2]

  t_schouten <- (n - 1) *
    (abs(prod(ad) - prod(bc)) - 0.5 * min(n1, n2))^2 /
    (n1 * n2 * sum(ac) * sum(bd))

  1 - stats::pchisq(t_schouten, df = 1)
}

#' @describeIn h_prop_diff_test performs the Fisher's exact test.
#'   Internally calls [stats::fisher.test()].
#'
#' @examples
#' ## Fisher's exact test
#' # Internal function - prop_fisher
#' \dontrun{
#' prop_fisher(tbl)
#' }
#'
#' @keywords internal
prop_fisher <- function(tbl) {
  checkmate::assert_integer(c(ncol(tbl), nrow(tbl)), lower = 2, upper = 2)
  tbl <- tbl[, c("TRUE", "FALSE")]
  stats::fisher.test(tbl)$p.value
}

#' Counting Patients Summing Exposure Across All Patients in Columns
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Counting the number of patients and summing analysis value (i.e exposure values) across all patients
#' when a column table layout is required.
#'
#' @name summarize_patients_exposure_in_cols
#'
NULL

#' @describeIn summarize_patients_exposure_in_cols Statistics function which counts numbers
#'  of patients and the sum of exposure across all patients.
#'
#' @inheritParams argument_convention
#' @param custom_label (`string` or `NULL`)\cr if provided and `labelstr` is empty then this will
#'   be used as label.
#' @return [s_count_patients_sum_exposure()] returns a list with the statistics:
#' \describe{
#'   \item{n_patients}{number of unique patients in `df`.}
#'   \item{sum_exposure}{sum of `.var` across all patients in `df`.}
#' }
#'
#' @examples
#' set.seed(1)
#' df <- data.frame(
#'   USUBJID = c(paste("id", seq(1, 12), sep = "")),
#'   ARMCD = c(rep("ARM A", 6), rep("ARM B", 6)),
#'   SEX = c(rep("Female", 6), rep("Male", 6)),
#'   AVAL = as.numeric(sample(seq(1, 20), 12)),
#'   stringsAsFactors = TRUE
#' )
#' adsl <- data.frame(
#'   USUBJID = c(paste("id", seq(1, 12), sep = "")),
#'   ARMCD = c(rep("ARM A", 2), rep("ARM B", 2)),
#'   SEX = c(rep("Female", 2), rep("Male", 2)),
#'   stringsAsFactors = TRUE
#' )
#'
#' # Internal function - s_count_patients_sum_exposure
#' \dontrun{
#' s_count_patients_sum_exposure(df = df, .N_col = nrow(adsl))
#' s_count_patients_sum_exposure(
#'   df = df,
#'   .N_col = nrow(adsl),
#'   custom_label = "some user's custom label"
#' )
#' }
#'
#' @keywords internal
s_count_patients_sum_exposure <- function(df, # nolintr
                                          .var = "AVAL",
                                          id = "USUBJID",
                                          labelstr = "",
                                          .N_col, # nolintr
                                          custom_label = NULL) {
  assert_df_with_variables(df, list(.var = .var, id = id))
  checkmate::assert_string(id)
  checkmate::assert_string(labelstr)
  checkmate::assert_string(custom_label, null.ok = TRUE)
  checkmate::assert_numeric(df[[.var]])

  row_label <- if (labelstr != "") {
    labelstr
  } else if (!is.null(custom_label)) {
    custom_label
  } else {
    "Total patients numbers/person time"
  }

  y <- list()

  y$n_patients <-
    formatters::with_label(
      s_num_patients_content(
        df = df,
        .N_col = .N_col, # nolintr
        .var = id,
        labelstr = ""
      )$unique,
      row_label
    )

  y$sum_exposure <- formatters::with_label(sum(df[[.var]]), row_label)
  y
}

#' @describeIn summarize_patients_exposure_in_cols Layout creating function which adds the count
#'   statistics of patients and the sum of analysis value in the column layout as content rows.
#'
#' @inheritParams argument_convention
#' @param col_split (`flag`)\cr whether the columns should be split. Set to `FALSE` when the required
#'   column split has been done already earlier in the layout pipe.
#' @export
#'
#' @examples
#' lyt <- basic_table() %>%
#'   split_cols_by("ARMCD", split_fun = add_overall_level("Total", first = FALSE)) %>%
#'   summarize_patients_exposure_in_cols(var = "AVAL", col_split = TRUE) %>%
#'   split_rows_by("SEX") %>%
#'   summarize_patients_exposure_in_cols(var = "AVAL", col_split = FALSE)
#' result <- build_table(lyt, df = df, alt_counts_df = adsl)
#' result
#'
#' lyt2 <- basic_table() %>%
#'   split_cols_by("ARMCD", split_fun = add_overall_level("Total", first = FALSE)) %>%
#'   summarize_patients_exposure_in_cols(
#'     var = "AVAL", col_split = TRUE,
#'     .stats = "n_patients", custom_label = "some custom label"
#'   ) %>%
#'   split_rows_by("SEX") %>%
#'   summarize_patients_exposure_in_cols(var = "AVAL", col_split = FALSE)
#' result2 <- build_table(lyt2, df = df, alt_counts_df = adsl)
#' result2
#'
#' lyt3 <- basic_table() %>%
#'   summarize_patients_exposure_in_cols(var = "AVAL", col_split = TRUE)
#' result3 <- build_table(lyt3, df = df, alt_counts_df = adsl)
#' result3
#'
#' lyt4 <- basic_table() %>%
#'   summarize_patients_exposure_in_cols(var = "AVAL", col_split = TRUE, .stats = "sum_exposure")
#' result4 <- build_table(lyt4, df = df, alt_counts_df = adsl)
#' result4
summarize_patients_exposure_in_cols <- function(lyt, # nolintr
                                                var,
                                                ...,
                                                .stats = c("n_patients", "sum_exposure"),
                                                .labels = c(n_patients = "Patients", sum_exposure = "Person time"),
                                                .indent_mods = NULL,
                                                col_split = TRUE) {
  afun_list <- Map(
    function(stat) {
      make_afun(
        s_count_patients_sum_exposure,
        .stats = stat,
        .formats = ifelse(stat == "n_patients", "xx (xx.x%)", "xx")
      )
    },
    stat = .stats
  )

  if (col_split) {
    lyt <- split_cols_by_multivar(
      lyt = lyt,
      vars = rep(var, length(.stats)),
      varlabels = .labels[.stats]
    )
  }
  summarize_row_groups(
    lyt = lyt,
    var = var,
    cfun = afun_list,
    extra_args = list(...)
  )
}

#' Convert Table into Matrix of Strings
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Helper function to use mostly within tests. `with_spaces`parameter allows
#' to test not only for content but also indentation and table structure.
#' `print_txt_to_copy` instead facilitate the testing development by returning a well
#' formatted text that needs only to be copied and pasted in the expected output.
#'
#' @param x `rtables` table.
#' @param with_spaces Should the tested table keep the indentation and other relevant
#'   spaces?
#' @param print_txt_to_copy Utility to have a way to copy the input table directly
#'   into the expected variable instead of copying it too manually.
#'
#' @return A matrix of strings
#'
#' @export
to_string_matrix <- function(x, with_spaces = FALSE, print_txt_to_copy = FALSE) {
  checkmate::assert_flag(with_spaces)
  checkmate::assert_flag(print_txt_to_copy)

  # Producing the matrix to test
  if (with_spaces) {
    out <- strsplit(toString(matrix_form(x, TRUE)), "\\n")[[1]]
  } else {
    out <- matrix_form(x)$string
  }

  # Printing to console formatted output that needs to be copied in "expected"
  if (print_txt_to_copy) {
    out_tmp <- out
    if (!with_spaces) {
      out_tmp <- apply(out, 1, paste0, collapse = '", "')
    }
    cat(paste0('c(\n  "', paste0(out_tmp, collapse = '",\n  "'), '"\n)'))
  }

  # Return values
  return(out)
}

#' Blank for Missing Input
#'
#' Helper function to use in tabulating model results.
#'
#' @param x (`vector`)\cr input for a cell.
#'
#' @return Either empty character vector if all entries in `x` are missing (`NA`), or otherwise
#'   the unlisted version of `x`
#'
#' @keywords internal
unlist_and_blank_na <- function(x) {
  unl <- unlist(x)
  if (all(is.na(unl))) {
    character()
  } else {
    unl
  }
}

#' Constructor for Content Functions given Data Frame with Flag Input
#'
#' This can be useful for tabulating model results.
#'
#' @param analysis_var (`string`)\cr variable name for the column containing values to be
#'   returned by the content function.
#' @param flag_var (`string`)\cr variable name for the logical column identifying which
#'   row should be returned.
#' @param format (`string`)\cr `rtables` format to use.
#'
#' @return Content function which just gives `df$analysis_var` at the row identified by
#'   `.df_row$flag` in the given format.
#'
#' @keywords internal
cfun_by_flag <- function(analysis_var,
                         flag_var,
                         format = "xx") {
  checkmate::assert_string(analysis_var)
  checkmate::assert_string(flag_var)
  function(df, labelstr) {
    row_index <- which(df[[flag_var]])
    x <- unlist_and_blank_na(df[[analysis_var]][row_index])
    formatters::with_label(
      rcell(x, format = format),
      labelstr
    )
  }
}

#' Content Row Function to Add Row Total to Labels
#'
#' This takes the label of the latest row split level and adds the row total in parentheses.
#'
#' @inheritParams argument_convention
#'
#' @return list containing "row_count" with the row count value and the correct label.
#'
#' @note Important is here to not use `df` but `.N_row` in the implementation, because the former
#'   is already split by columns and will refer to the first column of the data only.
#'
#' @keywords internal
c_label_n <- function(df,
                      labelstr,
                      .N_row) { # nolint
  label <- paste0(labelstr, " (N=", .N_row, ")")
  list(row_count = formatters::with_label(c(.N_row, .N_row), label))
}

#' Layout Creating Function to Add Row Total Counts
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This works analogously to [rtables::add_colcounts()] but on the rows.
#'
#' @inheritParams argument_convention
#'
#' @return The modified layout where the latest row split labels now have the row-wise
#'   total counts (i.e. without column based subsetting) attached in parentheses. Row
#'   count values are contained in these row count rows but are not displayed so that
#'   they are not considered zero rows by default when pruning.
#'
#' @examples
#' basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   add_colcounts() %>%
#'   split_rows_by("RACE", split_fun = drop_split_levels) %>%
#'   add_rowcounts() %>%
#'   analyze("AGE", afun = list_wrap_x(summary), format = "xx.xx") %>%
#'   build_table(DM)
#'
#' @export
add_rowcounts <- function(lyt) {
  c_lbl_n_fun <- make_afun(
    c_label_n,
    .stats = c("row_count"),
    .formats = c(row_count = function(x, ...) "")
  )
  summarize_row_groups(
    lyt,
    cfun = c_lbl_n_fun
  )
}

#' Obtain Column Indices
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Helper function to extract column indices from a `VTableTree` for a given
#' vector of column names.
#'
#' @param table_tree (`VTableTree`)\cr table to extract the indices from.
#' @param col_names (`character`)\cr vector of column names.
#'
#' @return the vector of column indices.
#'
#' @export
h_col_indices <- function(table_tree, col_names) {
  checkmate::assert_class(table_tree, "VTableNodeInfo")
  checkmate::assert_subset(col_names, names(attr(col_info(table_tree), "cextra_args")), empty.ok = FALSE)
  match(col_names, names(attr(col_info(table_tree), "cextra_args")))
}

#' Labels or Names of List Elements
#'
#' Internal helper function for working with nested statistic function results which typically
#' don't have labels but names that we can use.
#'
#' @param x a list
#'
#' @return a character vector with the labels or names for the list elements
#'
#' @keywords internal
labels_or_names <- function(x) {
  checkmate::assert_multi_class(x, c("data.frame", "list"))
  labs <- sapply(x, obj_label)
  nams <- rlang::names2(x)
  label_is_null <- sapply(labs, is.null)
  result <- unlist(ifelse(label_is_null, nams, labs))
  return(result)
}

#' Convert to `rtable`
#'
#' @description`r lifecycle::badge("stable")`
#'
#' This is a new generic function to convert objects to `rtable` tables.
#'
#' @param x the object which should be converted to an `rtable`.
#' @param ... additional arguments for methods.
#'
#' @return The `rtable` object. Note that the concrete class will depend on the method
#'   which is used.
#'
#' @export
as.rtable <- function(x, ...) { # nolint
  UseMethod("as.rtable", x)
}

#' @describeIn as.rtable method for converting `data.frame` that contain numeric columns to `rtable`.
#'
#' @param format the format which should be used for the columns.
#' @method as.rtable data.frame
#'
#' @examples
#' x <- data.frame(
#'   a = 1:10,
#'   b = rnorm(10)
#' )
#' as.rtable(x)
#'
#' @export
as.rtable.data.frame <- function(x, format = "xx.xx", ...) { # nolint
  checkmate::assert_numeric(unlist(x))
  do.call(
    rtable,
    c(
      list(
        header = labels_or_names(x),
        format = format
      ),
      Map(
        function(row, row_name) {
          do.call(
            rrow,
            c(as.list(unname(row)),
              row.name = row_name
            )
          )
        },
        row = as.data.frame(t(x)),
        row_name = rownames(x)
      )
    )
  )
}

#' Split parameters
#'
#' @description `r lifecycle::badge("stable")`
#'
#' It divides the data in the vector `param` into the groups defined by `f`
#' based on specified `values`.
#' It is relevant in `rtables` layers so as to distribute parameters
#' `.stats` or' `.formats` into lists with items corresponding to
#' specific analysis function.
#'
#' @param param (`vector`)\cr the parameter to be split.
#' @param value (`vector`)\cr the value used to split.
#' @param f (`list` of `vectors`)\cr the reference to make the split
#'
#' @examples
#' f <- list(
#'   surv = c("pt_at_risk", "event_free_rate", "rate_se", "rate_ci"),
#'   surv_diff = c("rate_diff", "rate_diff_ci", "ztest_pval")
#' )
#'
#' .stats <- c("pt_at_risk", "rate_diff")
#' h_split_param(.stats, .stats, f = f)
#'
#' # $surv
#' # [1] "pt_at_risk"
#' #
#' # $surv_diff
#' # [1] "rate_diff"
#'
#' .formats <- c("pt_at_risk" = "xx", "event_free_rate" = "xxx")
#' h_split_param(.formats, names(.formats), f = f)
#'
#' # $surv
#' # pt_at_risk event_free_rate
#' # "xx"           "xxx"
#' #
#' # $surv_diff
#' # NULL
#'
#' @export
h_split_param <- function(param,
                          value,
                          f) {
  y <- lapply(f, function(x) param[value %in% x])
  lapply(y, function(x) if (length(x) == 0) NULL else x)
}

#' Get Selected Statistics Names
#'
#' Helper function to be used for creating `afun`.
#'
#' @param .stats (`vector` or `NULL`)\cr input to the layout creating function. Note that `NULL` means
#'   in this context that all default statistics should be used.
#' @param all_stats (`character`)\cr all statistics which can be selected here potentially.
#'
#' @return Character vector with the selected statistics.
#'
#' @keywords internal
afun_selected_stats <- function(.stats, all_stats) {
  checkmate::assert_character(.stats, null.ok = TRUE)
  checkmate::assert_character(all_stats)
  if (is.null(.stats)) {
    all_stats
  } else {
    intersect(.stats, all_stats)
  }
}


#' Add Variable Labels to Top Left Corner in Table
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Helper layout creating function to just append the variable labels of a given variables vector
#' from a given dataset in the top left corner. If a variable label is not found then the
#' variable name itself is used instead. Multiple variable labels are concatenated with slashes.
#'
#' @note This is not an optimal implementation of course, since we are using here the data set
#'   itself during the layout creation. When we have a more mature `rtables` implementation then
#'   this will also be improved or not necessary anymore.
#'
#' @inheritParams argument_convention
#' @param vars (`character`)\cr variable names of which the labels are to be looked up in `df`.
#' @param indent (`integer`)\cr non-negative number of nested indent space, default to 0L which means no indent.
#' 1L means two spaces indent, 2L means four spaces indent and so on.
#'
#' @return The modified layout.
#'
#' @examples
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   add_colcounts() %>%
#'   split_rows_by("SEX") %>%
#'   append_varlabels(DM, "SEX") %>%
#'   analyze("AGE", afun = mean) %>%
#'   append_varlabels(DM, "AGE", indent = 1)
#' build_table(lyt, DM)
#'
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_rows_by("SEX") %>%
#'   analyze("AGE", afun = mean) %>%
#'   append_varlabels(DM, c("SEX", "AGE"))
#' build_table(lyt, DM)
#'
#' @export
append_varlabels <- function(lyt, df, vars, indent = 0L) {
  if (checkmate::test_flag(indent)) {
    warning("indent argument is now accepting integers. Boolean indent will be converted to integers.")
    indent <- as.integer(indent)
  }

  checkmate::assert_data_frame(df)
  checkmate::assert_character(vars)
  checkmate::assert_count(indent)

  lab <- formatters::var_labels(df[vars], fill = TRUE)
  lab <- paste(lab, collapse = " / ")
  space <- paste(rep(" ", indent * 2), collapse = "")
  lab <- paste0(space, lab)

  append_topleft(lyt, lab)
}

#' Helper Functions for Tabulating Biomarker Effects on Survival by Subgroup
#'
#' @description`r lifecycle::badge("stable")`
#'
#' Helper functions which are documented here separately to not confuse the user
#' when reading about the user-facing functions.
#'
#' @inheritParams survival_biomarkers_subgroups
#' @inheritParams argument_convention
#' @inheritParams fit_coxreg_multivar
#' @name h_survival_biomarkers_subgroups
#'
#' @examples
#' library(dplyr)
#' library(forcats)
#'
#' adtte <- tern_ex_adtte
#'
#' # Save variable labels before data processing steps.
#' adtte_labels <- formatters::var_labels(adtte, fill = FALSE)
#'
#' adtte_f <- adtte %>%
#'   filter(PARAMCD == "OS") %>%
#'   mutate(
#'     AVALU = as.character(AVALU),
#'     is_event = CNSR == 0
#'   )
#' labels <- c("AVALU" = adtte_labels[["AVALU"]], "is_event" = "Event Flag")
#' formatters::var_labels(adtte_f)[names(labels)] <- labels
#'
NULL

#' @describeIn h_survival_biomarkers_subgroups helps with converting the "survival" function variable list
#'   to the "Cox regression" variable list. The reason is that currently there is an inconsistency between the variable
#'   names accepted by `extract_survival_subgroups()` and `fit_coxreg_multivar()`.
#' @param biomarker (`string`)\cr the name of the biomarker variable.
#'
#' @examples
#' # This is how the variable list is converted internally.
#' h_surv_to_coxreg_variables(
#'   variables = list(
#'     tte = "AVAL",
#'     is_event = "EVNT",
#'     covariates = c("A", "B"),
#'     strata = "D"
#'   ),
#'   biomarker = "AGE"
#' )
#'
#' @export
h_surv_to_coxreg_variables <- function(variables, biomarker) {
  checkmate::assert_list(variables)
  checkmate::assert_string(variables$tte)
  checkmate::assert_string(variables$is_event)
  checkmate::assert_string(biomarker)
  list(
    time = variables$tte,
    event = variables$is_event,
    arm = biomarker,
    covariates = variables$covariates,
    strata = variables$strata
  )
}

#' @describeIn h_survival_biomarkers_subgroups prepares estimates for number of events, patients and median survival
#'   times, as well as hazard ratio estimates, confidence intervals and p-values, for multiple biomarkers
#'   in a given single data set.
#'   `variables` corresponds to names of variables found in `data`, passed as a named list and requires elements
#'   `tte`, `is_event`, `biomarkers` (vector of continuous biomarker variables) and optionally `subgroups` and `strat`.
#'
#' @examples
#' # For a single population, estimate separately the effects
#' # of two biomarkers.
#' df <- h_coxreg_mult_cont_df(
#'   variables = list(
#'     tte = "AVAL",
#'     is_event = "is_event",
#'     biomarkers = c("BMRKR1", "AGE"),
#'     covariates = "SEX",
#'     strata = c("STRATA1", "STRATA2")
#'   ),
#'   data = adtte_f
#' )
#' df
#'
#' # If the data set is empty, still the corresponding rows with missings are returned.
#' h_coxreg_mult_cont_df(
#'   variables = list(
#'     tte = "AVAL",
#'     is_event = "is_event",
#'     biomarkers = c("BMRKR1", "AGE"),
#'     covariates = "REGION1",
#'     strata = c("STRATA1", "STRATA2")
#'   ),
#'   data = adtte_f[NULL, ]
#' )
#'
#' @export
h_coxreg_mult_cont_df <- function(variables,
                                  data,
                                  control = control_coxreg()) {
  assert_df_with_variables(data, variables)
  checkmate::assert_list(control, names = "named")
  checkmate::assert_character(variables$biomarkers, min.len = 1, any.missing = FALSE)
  conf_level <- control[["conf_level"]]
  pval_label <- paste0(
    # the regex capitalizes the first letter of the string / senetence.
    "p-value (", gsub("(^[a-z])", "\\U\\1", trimws(control[["pval_method"]]), perl = TRUE), ")"
  )
  # If there is any data, run model, otherwise return empty results.
  if (nrow(data) > 0) {
    bm_cols <- match(variables$biomarkers, names(data))
    l_result <- lapply(variables$biomarkers, function(bm) {
      coxreg_list <- fit_coxreg_multivar(
        variables = h_surv_to_coxreg_variables(variables, bm),
        data = data,
        control = control
      )
      result <- do.call(
        h_coxreg_multivar_extract,
        c(list(var = bm), coxreg_list[c("mod", "data", "control")])
      )
      data_fit <- as.data.frame(as.matrix(coxreg_list$mod$y))
      data_fit$status <- as.logical(data_fit$status)
      median <- s_surv_time(
        df = data_fit,
        .var = "time",
        is_event = "status"
      )$median
      data.frame(
        # Dummy column needed downstream to create a nested header.
        biomarker = bm,
        biomarker_label = formatters::var_labels(data[bm], fill = TRUE),
        n_tot = coxreg_list$mod$n,
        n_tot_events = coxreg_list$mod$nevent,
        median = as.numeric(median),
        result[1L, c("hr", "lcl", "ucl")],
        conf_level = conf_level,
        pval = result[1L, "pval"],
        pval_label = pval_label,
        stringsAsFactors = FALSE
      )
    })
    do.call(rbind, args = c(l_result, make.row.names = FALSE))
  } else {
    data.frame(
      biomarker = variables$biomarkers,
      biomarker_label = formatters::var_labels(data[variables$biomarkers], fill = TRUE),
      n_tot = 0L,
      n_tot_events = 0L,
      median = NA,
      hr = NA,
      lcl = NA,
      ucl = NA,
      conf_level = conf_level,
      pval = NA,
      pval_label = pval_label,
      row.names = seq_along(variables$biomarkers),
      stringsAsFactors = FALSE
    )
  }
}

#' @describeIn h_survival_biomarkers_subgroups prepares a single sub-table given a `df_sub` containing
#'   the results for a single biomarker.
#' @param df (`data.frame`)\cr results for a single biomarker, as part of what is
#'   returned by [extract_survival_biomarkers()] (it needs a couple of columns which are
#'   added by that high-level function relative to what is returned by [h_coxreg_mult_cont_df()],
#'   see the example).
#'
#' @examples
#' # Starting from above `df`, zoom in on one biomarker and add required columns.
#' df1 <- df[1, ]
#' df1$subgroup <- "All patients"
#' df1$row_type <- "content"
#' df1$var <- "ALL"
#' df1$var_label <- "All patients"
#' h_tab_surv_one_biomarker(
#'   df1,
#'   vars = c("n_tot", "n_tot_events", "median", "hr", "ci", "pval"),
#'   time_unit = "days"
#' )
#'
#' @export
h_tab_surv_one_biomarker <- function(df,
                                     vars,
                                     time_unit) {
  afuns <- a_survival_subgroups()[vars]
  colvars <- d_survival_subgroups_colvars(
    vars,
    conf_level = df$conf_level[1],
    method = df$pval_label[1],
    time_unit = time_unit
  )
  h_tab_one_biomarker(
    df = df,
    afuns = afuns,
    colvars = colvars
  )
}

#' Additional Formatting Functions
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This summarizes the additional Formatting Functions to work with `rtables`.
#'
#' @family formatting functions
#' @name formatting_functions
NULL

#' Formatting Fraction and Percentage
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Formats a fraction together with ratio in percent.
#'
#' @param x (`integer`)\cr with elements `num` and `denom`.
#' @param ... required for `rtables` interface.
#' @return a string in the format `num / denom (ratio %)`. If `num` is 0 the format is `num / denom`.
#'
#' @examples
#' format_fraction(x = c(num = 2L, denom = 3L))
#' format_fraction(x = c(num = 0L, denom = 3L))
#'
#' @family formatting functions
#' @export
format_fraction <- function(x, ...) {
  attr(x, "label") <- NULL

  checkmate::assert_vector(x)
  checkmate::assert_count(x["num"])
  checkmate::assert_count(x["denom"])

  result <- if (x["num"] == 0) {
    paste0(x["num"], "/", x["denom"])
  } else {
    paste0(
      x["num"], "/", x["denom"],
      " (", round(x["num"] / x["denom"] * 100, 1), "%)"
    )
  }

  return(result)
}

#' Formatting Fraction and Percentage with Fixed Single Decimal Place
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Formats a fraction together with ratio in percent with fixed single decimal place.
#' Includes trailing zero in case of whole number percentages to always keep one decimal place.
#'
#' @param x (`integer`)\cr with elements `num` and `denom`.
#' @param ... required for `rtables` interface.
#' @return a string in the format `num / denom (ratio %)`. If `num` is 0 the format is `num / denom`.
#'
#' @examples
#' format_fraction_fixed_dp(x = c(num = 1L, denom = 2L))
#' format_fraction_fixed_dp(x = c(num = 1L, denom = 4L))
#' format_fraction_fixed_dp(x = c(num = 0L, denom = 3L))
#'
#' @family formatting functions
#' @export
format_fraction_fixed_dp <- function(x, ...) {
  attr(x, "label") <- NULL
  checkmate::assert_vector(x)
  checkmate::assert_count(x["num"])
  checkmate::assert_count(x["denom"])

  result <- if (x["num"] == 0) {
    paste0(x["num"], "/", x["denom"])
  } else {
    paste0(
      x["num"], "/", x["denom"],
      " (", sprintf("%.1f", round(x["num"] / x["denom"] * 100, 1)), "%)"
    )
  }
  return(result)
}

#' Formatting Count and Fraction
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Formats a count together with fraction with special consideration when count is `0`.
#'
#' @param x (`integer`)\cr vector of length 2, count and fraction.
#' @param ... required for `rtables` interface.
#' @return a string in the format `count (fraction %)`. If `count` is 0 the format is `0`.
#'
#' @examples
#' format_count_fraction(x = c(2, 0.6667))
#' format_count_fraction(x = c(0, 0))
#'
#' @family formatting functions
#' @export
format_count_fraction <- function(x, ...) {
  attr(x, "label") <- NULL

  if (any(is.na(x))) {
    return("NA")
  }

  checkmate::assert_vector(x)
  checkmate::assert_integerish(x[1])
  assert_proportion_value(x[2], include_boundaries = TRUE)

  result <- if (x[1] == 0) {
    "0"
  } else {
    paste0(x[1], " (", round(x[2] * 100, 1), "%)")
  }

  return(result)
}

#' Formatting Count and Percentage with Fixed Single Decimal Place
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Formats a count together with fraction with special consideration when count is `0`.
#'
#' @param x (`integer`)\cr vector of length 2, count and fraction.
#' @param ... required for `rtables` interface.
#' @return a string in the format `count (fraction %)`. If `count` is 0 the format is `0`.
#'
#' @examples
#' format_count_fraction_fixed_dp(x = c(2, 0.6667))
#' format_count_fraction_fixed_dp(x = c(2, 0.5))
#' format_count_fraction_fixed_dp(x = c(0, 0))
#'
#' @family formatting functions
#' @export
format_count_fraction_fixed_dp <- function(x, ...) {
  attr(x, "label") <- NULL

  if (any(is.na(x))) {
    return("NA")
  }

  checkmate::assert_vector(x)
  checkmate::assert_integerish(x[1])
  assert_proportion_value(x[2], include_boundaries = TRUE)

  result <- if (x[1] == 0) {
    "0"
  } else if (x[2] == 1) {
    sprintf("%d (100%%)", x[1])
  } else {
    sprintf("%d (%.1f%%)", x[1], x[2] * 100)
  }

  return(result)
}

#' Formatting: XX as Formatting Function
#'
#' Translate a string where x and dots are interpreted as number place
#' holders, and others as formatting elements.
#'
#' @param str (`string`)\cr template.
#'
#' @return An `rtables` formatting function.
#'
#' @examples
#' test <- list(c(1.658, 0.5761), c(1e1, 785.6))
#'
#' z <- format_xx("xx (xx.x)")
#' sapply(test, z)
#'
#' z <- format_xx("xx.x - xx.x")
#' sapply(test, z)
#'
#' z <- format_xx("xx.x, incl. xx.x% NE")
#' sapply(test, z)
#'
#' @family formatting functions
#' @export
format_xx <- function(str) {
  # Find position in the string.
  positions <- gregexpr(pattern = "x+\\.x+|x+", text = str, perl = TRUE)
  x_positions <- regmatches(x = str, m = positions)[[1]]

  # Roundings depends on the number of x behind [.].
  roundings <- lapply(
    X = x_positions,
    function(x) {
      y <- strsplit(split = "\\.", x = x)[[1]]
      rounding <- function(x) {
        round(x, digits = ifelse(length(y) > 1, nchar(y[2]), 0))
      }
      return(rounding)
    }
  )

  rtable_format <- function(x, output) {
    values <- Map(y = x, fun = roundings, function(y, fun) fun(y))
    regmatches(x = str, m = positions)[[1]] <- values
    return(str)
  }

  return(rtable_format)
}

#' Formatting Fraction with Lower Threshold
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Formats a fraction when the second element of the input `x` is the fraction. It applies
#' a lower threshold, below which it is just stated that the fraction is smaller than that.
#'
#' @param threshold (`proportion`)\cr lower threshold.
#' @return An `rtables` Formatting Function that takes numeric input `x` where the second
#'   element is the fraction that is formatted. If the fraction is above or equal to the threshold,
#'   then it is displayed in percentage. If it is positive but below the threshold, it returns
#'   "<1" e.g. if the threshold is `0.01`. If it is zero, then just "0" is returned.
#'
#' @examples
#' format_fun <- format_fraction_threshold(0.05)
#' format_fun(x = c(20, 0.1))
#' format_fun(x = c(2, 0.01))
#' format_fun(x = c(0, 0))
#'
#' @family formatting functions
#' @export
format_fraction_threshold <- function(threshold) {
  assert_proportion_value(threshold)
  string_below_threshold <- paste0("<", round(threshold * 100))
  function(x, ...) {
    assert_proportion_value(x[2], include_boundaries = TRUE)
    ifelse(
      x[2] > 0.01,
      round(x[2] * 100),
      ifelse(
        x[2] == 0,
        "0",
        string_below_threshold
      )
    )
  }
}


#' Formatting Extreme Values
#'
#' @description `r lifecycle::badge("stable")`
#'
#' `Rtables` Formatting Functions that handle extreme values.
#'
#' @details For each input, apply a format to the specified number of `digits`. If the value is
#'    below a threshold, it returns "<0.01" e.g. if the number of `digits` is 2. If the value is
#'    above a threshold, it returns ">999.99" e.g. if the number of `digits` is 2.
#'    If it is zero, then returns "0.00".
#'
#' @param digits (`integer`)\cr number of decimal places to display.
#'
#' @family formatting functions
#' @name extreme_format
NULL

#' @describeIn extreme_format Internal helper function to calculate the threshold and create formatted strings
#'  used in Formatting Functions. Returns a list with elements `threshold` and `format_string`.
#'
#' @examples
#' h_get_format_threshold(2L)
#'
#' @export
h_get_format_threshold <- function(digits = 2L) {
  checkmate::assert_integerish(digits)

  low_threshold <- 1 / (10 ^ digits) # styler: off
  high_threshold <- 1000 - (1 / (10 ^ digits)) # styler: off

  string_below_threshold <- paste0("<", low_threshold)
  string_above_threshold <- paste0(">", high_threshold)

  list(
    "threshold" = c(low = low_threshold, high = high_threshold),
    "format_string" = c(low = string_below_threshold, high = string_above_threshold)
  )
}

#' @describeIn extreme_format Internal helper function to apply a threshold format to a value.
#'   Creates a formatted string to be used in Formatting Functions.
#'
#' @param x (`number`)\cr value to format.
#'
#' @examples
#' h_format_threshold(0.001)
#' h_format_threshold(1000)
#'
#' @export
h_format_threshold <- function(x, digits = 2L) {
  if (is.na(x)) {
    return(x)
  }

  checkmate::assert_numeric(x, lower = 0)

  l_fmt <- h_get_format_threshold(digits)

  result <- if (x < l_fmt$threshold["low"] && 0 < x) {
    l_fmt$format_string["low"]
  } else if (x > l_fmt$threshold["high"]) {
    l_fmt$format_string["high"]
  } else {
    sprintf(fmt = paste0("%.", digits, "f"), x)
  }

  unname(result)
}

#' Formatting a Single Extreme Value
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Create Formatting Function for a single extreme value.
#'
#' @inheritParams extreme_format
#' @examples
#'
#' format_fun <- format_extreme_values(2L)
#' format_fun(x = 0.127)
#' format_fun(x = Inf)
#' format_fun(x = 0)
#' format_fun(x = 0.009)
#'
#' @family formatting functions
#' @export
format_extreme_values <- function(digits = 2L) {
  function(x, ...) {
    checkmate::assert_scalar(x, na.ok = TRUE)

    h_format_threshold(x = x, digits = digits)
  }
}

#' Formatting Extreme Values Part of a Confidence Interval
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Formatting Function for extreme values part of a confidence interval. Values
#' are formatted as e.g. "(xx.xx, xx.xx)" if if the number of `digits` is 2.
#'
#' @inheritParams extreme_format
#'
#' @examples
#' format_fun <- format_extreme_values_ci(2L)
#' format_fun(x = c(0.127, Inf))
#' format_fun(x = c(0, 0.009))
#'
#' @family formatting functions
#' @export
format_extreme_values_ci <- function(digits = 2L) {
  function(x, ...) {
    checkmate::assert_vector(x, len = 2)
    l_result <- h_format_threshold(x = x[1], digits = digits)
    h_result <- h_format_threshold(x = x[2], digits = digits)

    paste0("(", l_result, ", ", h_result, ")")
  }
}

#' Number of patients
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Count the number of unique and non-unique patients in a column (variable).
#'
#' @inheritParams argument_convention
#' @param x (`character` or `factor`)\cr vector of patient IDs.
#' @param count_by (`character` or `factor`)\cr optional vector to be combined with `x` when counting
#' `nonunique` records.
#' @param unique_count_suffix (`logical`)\cr should `"(n)"` suffix be added to `unique_count` labels.
#' Defaults to `TRUE`.
#'
#' @name summarize_num_patients
NULL

#' @describeIn summarize_num_patients Statistics function which counts the number of
#'   unique patients, the corresponding percentage taken with respect to the
#'   total number of patients, and the number of non-unique patients.
#'
#' @return A list with:
#' \describe{
#'   \item{unique}{vector of count and percentage.}
#'   \item{nonunique}{vector of count.}
#'   \item{unique_count}{count.}
#' }
#'
#' @examples
#' # Use the statistics function to count number of unique and nonunique patients.
#' s_num_patients(x = as.character(c(1, 1, 1, 2, 4, NA)), labelstr = "", .N_col = 6L)
#' s_num_patients(
#'   x = as.character(c(1, 1, 1, 2, 4, NA)),
#'   labelstr = "",
#'   .N_col = 6L,
#'   count_by = as.character(c(1, 1, 2, 1, 1, 1))
#' )
#'
#' @export
s_num_patients <- function(x, labelstr, .N_col, count_by = NULL, unique_count_suffix = TRUE) { # nolint

  checkmate::assert_string(labelstr)
  checkmate::assert_count(.N_col)
  checkmate::assert_multi_class(x, classes = c("factor", "character"))
  checkmate::assert_flag(unique_count_suffix)

  count1 <- n_available(unique(x))
  count2 <- n_available(x)

  if (!is.null(count_by)) {
    checkmate::assert_vector(count_by, len = length(x))
    checkmate::assert_multi_class(count_by, classes = c("factor", "character"))
    count2 <- n_available(unique(interaction(x, count_by)))
  }

  out <- list(
    unique = formatters::with_label(c(count1, ifelse(count1 == 0 && .N_col == 0, 0, count1 / .N_col)), labelstr),
    nonunique = formatters::with_label(count2, labelstr),
    unique_count = formatters::with_label(count1, ifelse(unique_count_suffix, paste(labelstr, "(n)"), labelstr))
  )

  out
}

#' @describeIn summarize_num_patients Counts the number of unique patients in a column
#'   (variable), the corresponding percentage taken with respect to the total
#'   number of patients, and the number of non-unique patients in the column.
#'   Function serves as a wrapper that carries over both expected arguments `df`
#'   and `labelstr` in `cfun` of [summarize_row_groups()].
#'
#' @param required (`character` or `NULL`)\cr optional name of a variable that is required to be non-missing.
#' @export
#'
#' @examples
#' # Count number of unique and non-unique patients.
#' df <- data.frame(
#'   USUBJID = as.character(c(1, 2, 1, 4, NA)),
#'   EVENT = as.character(c(10, 15, 10, 17, 8))
#' )
#' s_num_patients_content(df, .N_col = 5, .var = "USUBJID")
#'
#' df_by_event <- data.frame(
#'   USUBJID = as.character(c(1, 2, 1, 4, NA)),
#'   EVENT = as.character(c(10, 15, 10, 17, 8))
#' )
#' s_num_patients_content(df_by_event, .N_col = 5, .var = "USUBJID")
#' s_num_patients_content(df_by_event, .N_col = 5, .var = "USUBJID", count_by = "EVENT")
s_num_patients_content <- function(df, labelstr = "", .N_col, .var, required = NULL, count_by = NULL, unique_count_suffix = TRUE) { # nolint

  checkmate::assert_string(.var)
  checkmate::assert_data_frame(df)
  if (is.null(count_by)) {
    assert_df_with_variables(df, list(id = .var))
  } else {
    assert_df_with_variables(df, list(id = .var, count_by = count_by))
  }
  if (!is.null(required)) {
    checkmate::assert_string(required)
    assert_df_with_variables(df, list(required = required))
    df <- df[!is.na(df[[required]]), , drop = FALSE]
  }

  x <- df[[.var]]
  y <- switch(as.numeric(!is.null(count_by)) + 1,
    NULL,
    df[[count_by]]
  )

  s_num_patients(
    x = x,
    labelstr = labelstr,
    .N_col = .N_col,
    count_by = y,
    unique_count_suffix = unique_count_suffix
  )
}

c_num_patients <- make_afun(
  s_num_patients_content,
  .stats = c("unique", "nonunique", "unique_count"),
  .formats = c(unique = format_count_fraction_fixed_dp, nonunique = "xx", unique_count = "xx")
)

#' @describeIn summarize_num_patients Layout creating function which adds content rows using the statistics
#' function [s_num_patients_content()] and desired format.
#'
#' @export
summarize_num_patients <- function(lyt,
                                   var,
                                   .stats = NULL,
                                   .formats = NULL,
                                   .labels = c(
                                     unique = "Number of patients with at least one event",
                                     nonunique = "Number of events"
                                   ),
                                   indent_mod = 0L,
                                   ...) {
  if (is.null(.stats)) .stats <- c("unique", "nonunique", "unique_count")
  if (length(.labels) > length(.stats)) .labels <- .labels[names(.labels) %in% .stats]

  cfun <- make_afun(
    c_num_patients,
    .stats = .stats,
    .formats = .formats,
    .labels = .labels
  )

  summarize_row_groups(
    lyt = lyt,
    var = var,
    cfun = cfun,
    extra_args = list(...),
    indent_mod = indent_mod
  )
}

#' @describeIn summarize_num_patients Identically to [summarize_num_patients()],
#'   This function creates a layout which adds content rows using the statistics
#'   function [s_num_patients_content()] and desired format. Differently from its
#'   counterpart, this function does not impose the produced rows to be repeated.
#'
#' @details In general, functions that starts with `analyze*` are expected to
#'   work like [rtables::analyze()], while functions that starts with `summarize*`
#'   are based upon [rtables::summarize_row_groups()]. The latter provides a
#'   value for each dividing split in the row and column space, but, being it
#'   bound to the fundamental splits, it is repeated by design in every page
#'   when pagination is involved.
#'
#' @examples
#' df_tmp <- data.frame(
#'   USUBJID = as.character(c(1, 2, 1, 4, NA, 6, 6, 8, 9)),
#'   ARM = c("A", "A", "A", "A", "A", "B", "B", "B", "B"),
#'   AGE = c(10, 15, 10, 17, 8, 11, 11, 19, 17)
#' )
#' tbl <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   add_colcounts() %>%
#'   analyze_num_patients("USUBJID", .stats = c("unique")) %>%
#'   build_table(df_tmp)
#' tbl
#'
#' @export
analyze_num_patients <- function(lyt,
                                 vars,
                                 .stats = NULL,
                                 .formats = NULL,
                                 .labels = c(
                                   unique = "Number of patients with at least one event",
                                   nonunique = "Number of events"
                                 ),
                                 show_labels = c("default", "visible", "hidden"),
                                 indent_mod = 0L,
                                 ...) {
  if (is.null(.stats)) .stats <- c("unique", "nonunique", "unique_count")
  if (length(.labels) > length(.stats)) .labels <- .labels[names(.labels) %in% .stats]

  afun <- make_afun(
    c_num_patients,
    .stats = .stats,
    .formats = .formats,
    .labels = .labels
  )

  analyze(
    afun = afun,
    lyt = lyt,
    vars = vars,
    extra_args = list(...),
    show_labels = show_labels,
    indent_mod = indent_mod
  )
}

#' Helper Function for Deriving Analysis Datasets for LBT13 and LBT14
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Helper function that merges `ADSL` and `ADLB` datasets so that missing lab test records are inserted in the
#' output dataset.
#'
#' @param adsl (`data.frame`)\cr `ADSL` dataframe.
#' @param adlb (`data.frame`)\cr `ADLB` dataframe.
#' @param worst_flag (named `vector`)\cr Worst post-baseline lab flag variable.
#' @param by_visit (`logical`)\cr defaults to `FALSE` to generate worst grade per patient.
#'   If worst grade per patient per visit is specified for `worst_flag`, then
#'   `by_visit` should be `TRUE` to generate worst grade patient per visit.
#' @param no_fillin_visits (named `character`)\cr Visits that are not considered for post-baseline worst toxicity
#'   grade. Defaults to `c("SCREENING", "BASELINE")`.
#'
#' @return `df` containing variables shared between `adlb` and `adsl` along with variables relevant for analysis:
#'   `PARAM`, `PARAMCD`, `ATOXGR`, and `BTOXGR`.  Optionally `AVISIT`, `AVISITN` are included when `by_visit = TRUE`
#'   and `no_fillin_visits = c("SCREENING", "BASELINE")`.
#'
#' @export
#'
#' @details In the result data missing records will be created for the following situations:
#'   * Patients who are present in `adsl` but have no lab data in `adlb` (both baseline and post-baseline).
#'   * Patients who do not have any post-baseline lab values.
#'   * Patients without any post-baseline values flagged as the worst.
#'
#' @examples
#' # `h_adsl_adlb_merge_using_worst_flag`
#' adlb_out <- h_adsl_adlb_merge_using_worst_flag(
#'   tern_ex_adsl,
#'   tern_ex_adlb,
#'   worst_flag = c("WGRHIFL" = "Y")
#' )
#'
#' # `h_adsl_adlb_merge_using_worst_flag` by visit example
#' adlb_out_by_visit <- h_adsl_adlb_merge_using_worst_flag(
#'   tern_ex_adsl,
#'   tern_ex_adlb,
#'   worst_flag = c("WGRLOVFL" = "Y"),
#'   by_visit = TRUE
#' )
h_adsl_adlb_merge_using_worst_flag <- function(adsl, # nolint
                                               adlb,
                                               worst_flag = c("WGRHIFL" = "Y"),
                                               by_visit = FALSE,
                                               no_fillin_visits = c("SCREENING", "BASELINE")) {
  col_names <- names(worst_flag)
  filter_values <- worst_flag

  temp <- Map(
    function(x, y) which(adlb[[x]] == y),
    col_names,
    filter_values
  )

  position_satisfy_filters <- Reduce(intersect, temp)

  adsl_adlb_common_columns <- intersect(colnames(adsl), colnames(adlb))
  columns_from_adlb <- c("USUBJID", "PARAM", "PARAMCD", "AVISIT", "AVISITN", "ATOXGR", "BTOXGR")

  adlb_f <- adlb[position_satisfy_filters, ] %>%
    dplyr::filter(!.data[["AVISIT"]] %in% no_fillin_visits)
  adlb_f <- adlb_f[, columns_from_adlb]

  avisits_grid <- adlb %>%
    dplyr::filter(!.data[["AVISIT"]] %in% no_fillin_visits) %>%
    dplyr::pull(.data[["AVISIT"]]) %>%
    unique()

  if (by_visit) {
    adsl_lb <- expand.grid(
      USUBJID = unique(adsl$USUBJID),
      AVISIT = avisits_grid,
      PARAMCD = unique(adlb$PARAMCD)
    )

    adsl_lb <- adsl_lb %>%
      dplyr::left_join(unique(adlb[c("AVISIT", "AVISITN")]), by = "AVISIT") %>%
      dplyr::left_join(unique(adlb[c("PARAM", "PARAMCD")]), by = "PARAMCD")

    adsl1 <- adsl[, adsl_adlb_common_columns]
    adsl_lb <- adsl1 %>% merge(adsl_lb, by = "USUBJID")

    by_variables_from_adlb <- c("USUBJID", "AVISIT", "AVISITN", "PARAMCD", "PARAM")

    adlb_btoxgr <- adlb %>%
      dplyr::select(c("USUBJID", "PARAMCD", "BTOXGR")) %>%
      unique() %>%
      dplyr::rename("BTOXGR_MAP" = "BTOXGR")

    adlb_out <- merge(
      adlb_f,
      adsl_lb,
      by = by_variables_from_adlb,
      all = TRUE,
      sort = FALSE
    )
    adlb_out <- adlb_out %>%
      dplyr::left_join(adlb_btoxgr, by = c("USUBJID", "PARAMCD")) %>%
      dplyr::mutate(BTOXGR = .data$BTOXGR_MAP) %>%
      dplyr::select(-"BTOXGR_MAP")

    adlb_var_labels <- c(
      formatters::var_labels(adlb[by_variables_from_adlb]),
      formatters::var_labels(adlb[columns_from_adlb[!columns_from_adlb %in% by_variables_from_adlb]]),
      formatters::var_labels(adsl[adsl_adlb_common_columns[adsl_adlb_common_columns != "USUBJID"]])
    )
  } else {
    adsl_lb <- expand.grid(
      USUBJID = unique(adsl$USUBJID),
      PARAMCD = unique(adlb$PARAMCD)
    )

    adsl_lb <- adsl_lb %>% dplyr::left_join(unique(adlb[c("PARAM", "PARAMCD")]), by = "PARAMCD")

    adsl1 <- adsl[, adsl_adlb_common_columns]
    adsl_lb <- adsl1 %>% merge(adsl_lb, by = "USUBJID")

    by_variables_from_adlb <- c("USUBJID", "PARAMCD", "PARAM")

    adlb_out <- merge(
      adlb_f,
      adsl_lb,
      by = by_variables_from_adlb,
      all = TRUE,
      sort = FALSE
    )

    adlb_var_labels <- c(
      formatters::var_labels(adlb[by_variables_from_adlb]),
      formatters::var_labels(adlb[columns_from_adlb[!columns_from_adlb %in% by_variables_from_adlb]]),
      formatters::var_labels(adsl[adsl_adlb_common_columns[adsl_adlb_common_columns != "USUBJID"]])
    )
  }

  adlb_out$ATOXGR <- as.factor(adlb_out$ATOXGR) # nolint
  adlb_out$BTOXGR <- as.factor(adlb_out$BTOXGR) # nolint

  adlb_out <- df_explicit_na(adlb_out)
  formatters::var_labels(adlb_out) <- adlb_var_labels

  adlb_out
}

#' Control Function for Subgroup Treatment Effect Pattern (STEP) Calculations
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This is an auxiliary function for controlling arguments for STEP calculations.
#'
#' @param biomarker (`numeric` or `NULL`)\cr optional provision of the numeric biomarker variable, which
#'   could be used to infer `bandwidth`, see below.
#' @param use_percentile (`flag`)\cr if `TRUE`, the running windows are created according to
#'   quantiles rather than actual values, i.e. the bandwidth refers to the percentage of data
#'   covered in each window. Suggest `TRUE` if the biomarker variable is not uniformly
#'   distributed.
#' @param bandwidth (`number` or `NULL`)\cr indicating the bandwidth of each window.
#'    Depending on the argument `use_percentile`, it can be either the length of actual-value
#'    windows on the real biomarker scale, or percentage windows.
#'    If `use_percentile = TRUE`, it should be a number between 0 and 1.
#'    If `NULL`, treat the bandwidth to be infinity, which means only one global model will be fitted.
#'    By default, `0.25` is used for percentage windows and one quarter of the range of the `biomarker`
#'    variable for actual-value windows.
#' @param degree (`count`)\cr the degree of polynomial function of the biomarker as an interaction term
#'   with the treatment arm fitted at each window. If 0 (default), then the biomarker variable
#'   is not included in the model fitted in each biomarker window.
#' @param num_points (`count`)\cr the number of points at which the hazard ratios are estimated. The
#'   smallest number is 2.
#'
#' @return A list of components with the same names as the arguments, except `biomarker` which is
#'   just used to calculate the `bandwidth` in case that actual biomarker windows are requested.
#'
#' @examples
#' # Provide biomarker values and request actual values to be used,
#' # so that bandwidth is chosen from range.
#' control_step(biomarker = 1:10, use_percentile = FALSE)
#'
#' # Use a global model with quadratic biomarker interaction term.
#' control_step(bandwidth = NULL, degree = 2)
#'
#' # Reduce number of points to be used.
#' control_step(num_points = 10)
#'
#' @export
control_step <- function(biomarker = NULL,
                         use_percentile = TRUE,
                         bandwidth,
                         degree = 0L,
                         num_points = 39L) {
  checkmate::assert_numeric(biomarker, null.ok = TRUE)
  checkmate::assert_flag(use_percentile)
  checkmate::assert_int(num_points, lower = 2)
  checkmate::assert_count(degree)

  if (missing(bandwidth)) {
    # Infer bandwidth
    bandwidth <- if (use_percentile) {
      0.25
    } else if (!is.null(biomarker)) {
      diff(range(biomarker, na.rm = TRUE)) / 4
    } else {
      NULL
    }
  } else {
    # Check bandwidth
    if (!is.null(bandwidth)) {
      if (use_percentile) {
        assert_proportion_value(bandwidth)
      } else {
        checkmate::assert_scalar(bandwidth)
        checkmate::assert_true(bandwidth > 0)
      }
    }
  }
  list(
    use_percentile = use_percentile,
    bandwidth = bandwidth,
    degree = as.integer(degree),
    num_points = as.integer(num_points)
  )
}

#' `rtables` Access Helper Functions
#'
#' @description`r lifecycle::badge("stable")`
#'
#' These are a couple of functions that help with accessing the data in `rtables` objects.
#' Currently these work for occurrence tables, which are defined
#' as having a count as the first element and a fraction as the second element in each cell.
#'
#' @seealso [prune_occurrences] for usage of these functions.
#'
#' @name rtables_access
NULL

#' @describeIn rtables_access helper function to extract the first values from each content
#'   cell and from specified columns in a `TableRow`. Defaults to all columns.
#'
#' @param table_row (`TableRow`)\cr an analysis row in a occurrence table.
#' @param col_names (`character`)\cr the names of the columns to extract from.
#' @param col_indices (`integer`)\cr the indices of the columns to extract from.
#'   If `col_names` are provided, then these are inferred from the names of
#'   `table_row`. (Note that this currently only works well with a single
#'   column split.)
#'
#' @examples
#' tbl <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_rows_by("RACE") %>%
#'   analyze("AGE", function(x) {
#'     list(
#'       "mean (sd)" = rcell(c(mean(x), sd(x)), format = "xx.x (xx.x)"),
#'       "n" = length(x),
#'       "frac" = rcell(c(0.1, 0.1), format = "xx (xx)")
#'     )
#'   }) %>%
#'   build_table(tern_ex_adsl) %>%
#'   prune_table()
#' tree_row_elem <- collect_leaves(tbl[2, ])[[1]]
#' result <- max(h_row_first_values(tree_row_elem))
#' result
#'
#' @export
h_row_first_values <- function(table_row,
                               col_names = NULL,
                               col_indices = NULL) {
  col_indices <- check_names_indices(table_row, col_names, col_indices)
  checkmate::assert_integerish(col_indices)
  checkmate::assert_subset(col_indices, seq_len(ncol(table_row)))

  # Main values are extracted
  row_vals <- row_values(table_row)[col_indices]

  # Main return
  vapply(row_vals, function(rv) {
    if (is.null(rv)) {
      NA_real_
    } else {
      rv[1L]
    }
  }, FUN.VALUE = numeric(1))
}

#' @describeIn rtables_access Helper function that extracts row values and checks if they are
#'  convertible to integers (`integerish` values).
#'
#' @examples
#' # Row counts (integer values)
#' \dontrun{
#' h_row_counts(tree_row_elem) # Fails because there are no integers
#' }
#' # Using values with integers
#' tree_row_elem <- collect_leaves(tbl[3, ])[[1]]
#' result <- h_row_counts(tree_row_elem)
#' # result
#'
#' @export
h_row_counts <- function(table_row,
                         col_names = NULL,
                         col_indices = NULL) {
  counts <- h_row_first_values(table_row, col_names, col_indices)
  checkmate::assert_integerish(counts)
  counts
}

#' @describeIn rtables_access helper function to extract fractions from specified columns
#'   in a `TableRow`. More specifically it extracts the second values from each
#'   content cell and checks it is a fraction.
#'
#' @examples
#' # Row fractions
#' tree_row_elem <- collect_leaves(tbl[4, ])[[1]]
#' h_row_fractions(tree_row_elem)
#'
#' @export
h_row_fractions <- function(table_row,
                            col_names = NULL,
                            col_indices = NULL) {
  col_indices <- check_names_indices(table_row, col_names, col_indices)
  row_vals <- row_values(table_row)[col_indices]
  fractions <- sapply(row_vals, "[", 2L)
  checkmate::assert_numeric(fractions, lower = 0, upper = 1)
  fractions
}

#' @describeIn rtables_access Helper function to extract column counts from specified columns
#'   in a table.
#' @param table (`VTableNodeInfo`)\cr an occurrence table or row.
#'
#' @export
h_col_counts <- function(table,
                         col_names = NULL,
                         col_indices = NULL) {
  col_indices <- check_names_indices(table, col_names, col_indices)
  counts <- col_counts(table)[col_indices]
  stats::setNames(counts, col_names)
}

#' @describeIn rtables_access Helper function to get first row of content table of current table.
#'
#' @export
h_content_first_row <- function(table) {
  ct <- content_table(table)
  tree_children(ct)[[1]]
}

#' @describeIn rtables_access Helper function which says whether current table is a leaf in the tree.
#'
#' @keywords internal
is_leaf_table <- function(table) {
  children <- tree_children(table)
  child_classes <- unique(sapply(children, class))
  identical(child_classes, "ElementaryTable")
}

#' @describeIn rtables_access Internal helper function that tests standard inputs for column indices.
#'
#' @keywords internal
check_names_indices <- function(table_row,
                                col_names = NULL,
                                col_indices = NULL) {
  if (!is.null(col_names)) {
    if (!is.null(col_indices)) {
      stop(
        "Inserted both col_names and col_indices when selecting row values. ",
        "Please choose one."
      )
    }
    col_indices <- h_col_indices(table_row, col_names)
  }
  if (is.null(col_indices)) {
    ll <- ifelse(is.null(ncol(table_row)), length(table_row), ncol(table_row))
    col_indices <- seq_len(ll)
  }

  return(col_indices)
}

#' Helper Function to create a new `SMQ` variable in `ADAE` by stacking
#' `SMQ` and/or `CQ` records.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Helper Function to create a new `SMQ` variable in `ADAE` that
#' consists of all adverse events belonging to selected
#' Standardized/Customized queries.
#' The new dataset will only contain records of the adverse events
#' belonging to any of the selected baskets.
#'
#' @inheritParams argument_convention
#' @param baskets (`character`)\cr variable names of the selected Standardized/Customized queries.
#' @param smq_varlabel (`string`)\cr a label for the new variable created.
#' @param keys (`character`)\cr names of the key variables to be returned
#' along with the new variable created.
#' @param aag_summary (`data.frame`)\cr containing the `SMQ` baskets
#' and the levels of interest for the final `SMQ` variable. This is useful when
#' there are some levels of interest that are not observed in the `df` dataset.
#' The two columns of this dataset should be named `basket` and `basket_name`.
#'
#' @export
#'
#' @examples
#' adae <- tern_ex_adae[1:20, ] %>% df_explicit_na()
#' h_stack_by_baskets(df = adae)
#'
#' aag <- data.frame(
#'   NAMVAR = c("CQ01NAM", "CQ02NAM", "SMQ01NAM", "SMQ02NAM"),
#'   REFNAME = c(
#'     "D.2.1.5.3/A.1.1.1.1 AESI", "X.9.9.9.9/Y.8.8.8.8 AESI",
#'     "C.1.1.1.3/B.2.2.3.1 AESI", "C.1.1.1.3/B.3.3.3.3 AESI"
#'   ),
#'   SCOPE = c("", "", "BROAD", "BROAD"),
#'   stringsAsFactors = FALSE
#' )
#'
#' basket_name <- character(nrow(aag))
#' cq_pos <- grep("^(CQ).+NAM$", aag$NAMVAR)
#' smq_pos <- grep("^(SMQ).+NAM$", aag$NAMVAR)
#' basket_name[cq_pos] <- aag$REFNAME[cq_pos]
#' basket_name[smq_pos] <- paste0(
#'   aag$REFNAME[smq_pos], "(", aag$SCOPE[smq_pos], ")"
#' )
#'
#' aag_summary <- data.frame(
#'   basket = aag$NAMVAR,
#'   basket_name = basket_name,
#'   stringsAsFactors = TRUE
#' )
#'
#' result <- h_stack_by_baskets(df = adae, aag_summary = aag_summary)
#' all(levels(aag_summary$basket_name) %in% levels(result$SMQ))
#'
#' h_stack_by_baskets(
#'   df = adae,
#'   aag_summary = NULL,
#'   keys = c("STUDYID", "USUBJID", "AEDECOD", "ARM"),
#'   baskets = "SMQ01NAM"
#' )
h_stack_by_baskets <- function(df,
                               baskets = grep("^(SMQ|CQ).+NAM$", names(df), value = TRUE),
                               smq_varlabel = "Standardized MedDRA Query",
                               keys = c("STUDYID", "USUBJID", "ASTDTM", "AEDECOD", "AESEQ"),
                               aag_summary = NULL,
                               na_level = "<Missing>") {
  # Use of df_explicit_na() in case the user has not previously used
  df <- df_explicit_na(df, na_level = na_level)

  smq_nam <- baskets[startsWith(baskets, "SMQ")]
  # SC corresponding to NAM
  smq_sc <- gsub(pattern = "NAM", replacement = "SC", x = smq_nam, fixed = TRUE)
  smq <- stats::setNames(smq_sc, smq_nam)

  checkmate::assert_character(baskets)
  checkmate::assert_string(smq_varlabel)
  checkmate::assert_data_frame(df)
  checkmate::assert_true(all(startsWith(baskets, "SMQ") | startsWith(baskets, "CQ")))
  checkmate::assert_true(all(endsWith(baskets, "NAM")))
  checkmate::assert_subset(baskets, names(df))
  checkmate::assert_subset(keys, names(df))
  checkmate::assert_subset(smq_sc, names(df))
  checkmate::assert_string(na_level)

  if (!is.null(aag_summary)) {
    assert_df_with_variables(
      df = aag_summary,
      variables = list(val = c("basket", "basket_name"))
    )
    # Warning in case there is no match between `aag_summary$basket` and `baskets` argument.
    # Honestly, I think those should completely match. Target baskets should be the same.
    if (length(intersect(baskets, unique(aag_summary$basket))) == 0) {
      warning("There are 0 baskets in common between aag_summary$basket and `baskets` argument.")
    }
  }

  var_labels <- c(formatters::var_labels(df[, keys]), "SMQ" = smq_varlabel)

  # convert `na_level` records from baskets to NA for the later loop and from wide to long steps
  df[, c(baskets, smq_sc)][df[, c(baskets, smq_sc)] == na_level] <- NA

  if (all(is.na(df[, baskets]))) { # in case there is no level for the target baskets
    df_long <- df[-seq_len(nrow(df)), keys] # we just need an empty dataframe keeping all factor levels
  } else {
    # Concatenate SMQxxxNAM with corresponding SMQxxxSC
    df_cnct <- df[, c(keys, baskets[startsWith(baskets, "CQ")])]

    for (nam in names(smq)) {
      sc <- smq[nam] # SMQxxxSC corresponding to SMQxxxNAM
      nam_notna <- !is.na(df[[nam]])
      new_colname <- paste(nam, sc, sep = "_")
      df_cnct[nam_notna, new_colname] <- paste0(df[[nam]], "(", df[[sc]], ")")[nam_notna]
    }

    df_cnct$unique_id <- seq(1, nrow(df_cnct))
    var_cols <- names(df_cnct)[!(names(df_cnct) %in% c(keys, "unique_id"))]
    # have to convert df_cnct from tibble to dataframe
    # as it throws a warning otherwise about rownames.
    # tibble do not support rownames and reshape creates rownames

    df_long <- stats::reshape(
      data = as.data.frame(df_cnct),
      varying = var_cols,
      v.names = "SMQ",
      idvar = names(df_cnct)[names(df_cnct) %in% c(keys, "unique_id")],
      direction = "long",
      new.row.names = seq(prod(length(var_cols), nrow(df_cnct)))
    )

    df_long <- df_long[!is.na(df_long[, "SMQ"]), !(names(df_long) %in% c("time", "unique_id"))]
    df_long$SMQ <- as.factor(df_long$SMQ) # nolint
  }

  smq_levels <- setdiff(levels(df_long[["SMQ"]]), na_level)

  if (!is.null(aag_summary)) {
    # A warning in case there is no match between df and aag_summary records
    if (length(intersect(smq_levels, unique(aag_summary$basket_name))) == 0) {
      warning("There are 0 basket levels in common between aag_summary$basket_name and df.")
    }
    df_long[["SMQ"]] <- factor(
      df_long[["SMQ"]],
      levels = sort(
        c(
          smq_levels,
          setdiff(unique(aag_summary$basket_name), smq_levels)
        )
      )
    )
  } else {
    all_na_basket_flag <- vapply(df[, baskets], function(x) {
      all(is.na(x))
    }, FUN.VALUE = logical(1))
    all_na_basket <- baskets[all_na_basket_flag]

    df_long[["SMQ"]] <- factor(
      df_long[["SMQ"]],
      levels = sort(c(smq_levels, all_na_basket))
    )
  }
  formatters::var_labels(df_long) <- var_labels
  tibble::tibble(df_long)
}

#' Helper Functions for Tabulating Survival Duration by Subgroup
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Helper functions that tabulate in a data frame statistics such as median survival
#' time and hazard ratio for population subgroups.
#'
#' @details Main functionality is to prepare data for use in a layout creating function.
#'
#' @inheritParams argument_convention
#' @inheritParams survival_coxph_pairwise
#' @inheritParams survival_duration_subgroups
#' @param arm (`factor`)\cr the treatment group variable.
#' @name h_survival_duration_subgroups
#'
#' @examples
#' library(dplyr)
#' library(forcats)
#'
#' adtte <- tern_ex_adtte
#'
#' # Save variable labels before data processing steps.
#' adtte_labels <- formatters::var_labels(adtte)
#'
#' adtte_f <- adtte %>%
#'   filter(
#'     PARAMCD == "OS",
#'     ARM %in% c("B: Placebo", "A: Drug X"),
#'     SEX %in% c("M", "F")
#'   ) %>%
#'   mutate(
#'     # Reorder levels of ARM to display reference arm before treatment arm.
#'     ARM = droplevels(fct_relevel(ARM, "B: Placebo")),
#'     SEX = droplevels(SEX),
#'     is_event = CNSR == 0
#'   )
#' labels <- c("ARM" = adtte_labels[["ARM"]], "SEX" = adtte_labels[["SEX"]], "is_event" = "Event Flag")
#' formatters::var_labels(adtte_f)[names(labels)] <- labels
#'
NULL

#' @describeIn h_survival_duration_subgroups helper to prepare a data frame of median survival times by arm.
#' @inheritParams h_survival_duration_subgroups
#'
#' @examples
#' # Extract median survival time for one group.
#' h_survtime_df(
#'   tte = adtte_f$AVAL,
#'   is_event = adtte_f$is_event,
#'   arm = adtte_f$ARM
#' )
#'
#' @export
h_survtime_df <- function(tte, is_event, arm) {
  checkmate::assert_numeric(tte)
  checkmate::assert_logical(is_event, len = length(tte))
  assert_valid_factor(arm, len = length(tte))

  df_tte <- data.frame(
    tte = tte,
    is_event = is_event,
    stringsAsFactors = FALSE
  )

  # Delete NAs
  non_missing_rows <- stats::complete.cases(df_tte)
  df_tte <- df_tte[non_missing_rows, ]
  arm <- arm[non_missing_rows]

  lst_tte <- split(df_tte, arm)
  lst_results <- Map(function(x, arm) {
    if (nrow(x) > 0) {
      s_surv <- s_surv_time(x, .var = "tte", is_event = "is_event")
      median_est <- unname(as.numeric(s_surv$median))
      n_events <- sum(x$is_event)
    } else {
      median_est <- NA
      n_events <- NA
    }

    data.frame(
      arm = arm,
      n = nrow(x),
      n_events = n_events,
      median = median_est,
      stringsAsFactors = FALSE
    )
  }, lst_tte, names(lst_tte))

  df <- do.call(rbind, args = c(lst_results, make.row.names = FALSE))
  df$arm <- factor(df$arm, levels = levels(arm))
  df
}

#' @describeIn h_survival_duration_subgroups summarizes median survival times by arm and across subgroups
#'    in a data frame. `variables` corresponds to the names of variables found in `data`, passed as a named list and
#'    requires elements `tte`, `is_event`, `arm` and optionally `subgroups`. `groups_lists` optionally specifies
#'    groupings for `subgroups` variables.
#'
#' @examples
#' # Extract median survival time for multiple groups.
#' h_survtime_subgroups_df(
#'   variables = list(
#'     tte = "AVAL",
#'     is_event = "is_event",
#'     arm = "ARM",
#'     subgroups = c("SEX", "BMRKR2")
#'   ),
#'   data = adtte_f
#' )
#'
#' # Define groupings for BMRKR2 levels.
#' h_survtime_subgroups_df(
#'   variables = list(
#'     tte = "AVAL",
#'     is_event = "is_event",
#'     arm = "ARM",
#'     subgroups = c("SEX", "BMRKR2")
#'   ),
#'   data = adtte_f,
#'   groups_lists = list(
#'     BMRKR2 = list(
#'       "low" = "LOW",
#'       "low/medium" = c("LOW", "MEDIUM"),
#'       "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
#'     )
#'   )
#' )
#'
#' @export
h_survtime_subgroups_df <- function(variables,
                                    data,
                                    groups_lists = list(),
                                    label_all = "All Patients") {
  checkmate::assert_character(variables$tte)
  checkmate::assert_character(variables$is_event)
  checkmate::assert_character(variables$arm)
  checkmate::assert_character(variables$subgroups, null.ok = TRUE)

  assert_df_with_variables(data, variables)

  checkmate::assert_string(label_all)

  # Add All Patients.
  result_all <- h_survtime_df(data[[variables$tte]], data[[variables$is_event]], data[[variables$arm]])
  result_all$subgroup <- label_all
  result_all$var <- "ALL"
  result_all$var_label <- label_all
  result_all$row_type <- "content"

  # Add Subgroups.
  if (is.null(variables$subgroups)) {
    result_all
  } else {
    l_data <- h_split_by_subgroups(data, variables$subgroups, groups_lists = groups_lists)
    l_result <- lapply(l_data, function(grp) {
      result <- h_survtime_df(grp$df[[variables$tte]], grp$df[[variables$is_event]], grp$df[[variables$arm]])
      result_labels <- grp$df_labels[rep(1, times = nrow(result)), ]
      cbind(result, result_labels)
    })
    result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE))
    result_subgroups$row_type <- "analysis"
    rbind(
      result_all,
      result_subgroups
    )
  }
}

#' @describeIn h_survival_duration_subgroups helper to prepare a data frame with estimates of
#'   treatment hazard ratio.
#'
#' @param strata_data (`factor`, `data.frame` or `NULL`)\cr required if stratified analysis is performed.
#'
#' @examples
#' # Extract hazard ratio for one group.
#' h_coxph_df(adtte_f$AVAL, adtte_f$is_event, adtte_f$ARM)
#'
#' # Extract hazard ratio for one group with stratification factor.
#' h_coxph_df(adtte_f$AVAL, adtte_f$is_event, adtte_f$ARM, strata_data = adtte_f$STRATA1)
#'
#' @export
h_coxph_df <- function(tte, is_event, arm, strata_data = NULL, control = control_coxph()) {
  checkmate::assert_numeric(tte)
  checkmate::assert_logical(is_event, len = length(tte))
  assert_valid_factor(arm, n.levels = 2, len = length(tte))

  df_tte <- data.frame(tte = tte, is_event = is_event)
  strata_vars <- NULL

  if (!is.null(strata_data)) {
    if (is.data.frame(strata_data)) {
      strata_vars <- names(strata_data)
      checkmate::assert_data_frame(strata_data, nrows = nrow(df_tte))
      assert_df_with_factors(strata_data, as.list(stats::setNames(strata_vars, strata_vars)))
    } else {
      assert_valid_factor(strata_data, len = nrow(df_tte))
      strata_vars <- "strata_data"
    }
    df_tte[strata_vars] <- strata_data
  }

  l_df <- split(df_tte, arm)

  if (nrow(l_df[[1]]) > 0 && nrow(l_df[[2]]) > 0) {
    # Hazard ratio and CI.
    result <- s_coxph_pairwise(
      df = l_df[[2]],
      .ref_group = l_df[[1]],
      .in_ref_col = FALSE,
      .var = "tte",
      is_event = "is_event",
      strat = strata_vars,
      control = control
    )

    df <- data.frame(
      # Dummy column needed downstream to create a nested header.
      arm = " ",
      n_tot = unname(as.numeric(result$n_tot)),
      n_tot_events = unname(as.numeric(result$n_tot_events)),
      hr = unname(as.numeric(result$hr)),
      lcl = unname(result$hr_ci[1]),
      ucl = unname(result$hr_ci[2]),
      conf_level = control[["conf_level"]],
      pval = as.numeric(result$pvalue),
      pval_label = obj_label(result$pvalue),
      stringsAsFactors = FALSE
    )
  } else if (
    (nrow(l_df[[1]]) == 0 && nrow(l_df[[2]]) > 0) ||
      (nrow(l_df[[1]]) > 0 && nrow(l_df[[2]]) == 0)
  ) {
    df_tte_complete <- df_tte[stats::complete.cases(df_tte), ]
    df <- data.frame(
      # Dummy column needed downstream to create a nested header.
      arm = " ",
      n_tot = nrow(df_tte_complete),
      n_tot_events = sum(df_tte_complete$is_event),
      hr = NA,
      lcl = NA,
      ucl = NA,
      conf_level = control[["conf_level"]],
      pval = NA,
      pval_label = NA,
      stringsAsFactors = FALSE
    )
  } else {
    df <- data.frame(
      # Dummy column needed downstream to create a nested header.
      arm = " ",
      n_tot = 0L,
      n_tot_events = 0L,
      hr = NA,
      lcl = NA,
      ucl = NA,
      conf_level = control[["conf_level"]],
      pval = NA,
      pval_label = NA,
      stringsAsFactors = FALSE
    )
  }

  df
}

#' @describeIn h_survival_duration_subgroups summarizes estimates of the treatment hazard ratio
#'   across subgroups in a data frame. `variables` corresponds to the names of variables found in
#'   `data`, passed as a named list and requires elements `tte`, `is_event`, `arm` and
#'   optionally `subgroups` and `strat`. `groups_lists` optionally specifies
#'   groupings for `subgroups` variables.
#'
#' @examples
#' # Extract hazard ratio for multiple groups.
#' h_coxph_subgroups_df(
#'   variables = list(
#'     tte = "AVAL",
#'     is_event = "is_event",
#'     arm = "ARM",
#'     subgroups = c("SEX", "BMRKR2")
#'   ),
#'   data = adtte_f
#' )
#'
#' # Define groupings of BMRKR2 levels.
#' h_coxph_subgroups_df(
#'   variables = list(
#'     tte = "AVAL",
#'     is_event = "is_event",
#'     arm = "ARM",
#'     subgroups = c("SEX", "BMRKR2")
#'   ),
#'   data = adtte_f,
#'   groups_lists = list(
#'     BMRKR2 = list(
#'       "low" = "LOW",
#'       "low/medium" = c("LOW", "MEDIUM"),
#'       "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
#'     )
#'   )
#' )
#'
#' # Extract hazard ratio for multiple groups with stratification factors.
#' h_coxph_subgroups_df(
#'   variables = list(
#'     tte = "AVAL",
#'     is_event = "is_event",
#'     arm = "ARM",
#'     subgroups = c("SEX", "BMRKR2"),
#'     strat = c("STRATA1", "STRATA2")
#'   ),
#'   data = adtte_f
#' )
#'
#' @export
h_coxph_subgroups_df <- function(variables,
                                 data,
                                 groups_lists = list(),
                                 control = control_coxph(),
                                 label_all = "All Patients") {
  checkmate::assert_character(variables$tte)
  checkmate::assert_character(variables$is_event)
  checkmate::assert_character(variables$arm)
  checkmate::assert_character(variables$subgroups, null.ok = TRUE)
  checkmate::assert_character(variables$strat, null.ok = TRUE)
  assert_df_with_factors(data, list(val = variables$arm), min.levels = 2, max.levels = 2)
  assert_df_with_variables(data, variables)
  checkmate::assert_string(label_all)

  # Add All Patients.
  result_all <- h_coxph_df(
    tte = data[[variables$tte]],
    is_event = data[[variables$is_event]],
    arm = data[[variables$arm]],
    strata_data = if (is.null(variables$strat)) NULL else data[variables$strat],
    control = control
  )
  result_all$subgroup <- label_all
  result_all$var <- "ALL"
  result_all$var_label <- label_all
  result_all$row_type <- "content"

  # Add Subgroups.
  if (is.null(variables$subgroups)) {
    result_all
  } else {
    l_data <- h_split_by_subgroups(data, variables$subgroups, groups_lists = groups_lists)

    l_result <- lapply(l_data, function(grp) {
      result <- h_coxph_df(
        tte = grp$df[[variables$tte]],
        is_event = grp$df[[variables$is_event]],
        arm = grp$df[[variables$arm]],
        strata_data = if (is.null(variables$strat)) NULL else grp$df[variables$strat],
        control = control
      )
      result_labels <- grp$df_labels[rep(1, times = nrow(result)), ]
      cbind(result, result_labels)
    })

    result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE))
    result_subgroups$row_type <- "analysis"

    rbind(
      result_all,
      result_subgroups
    )
  }
}

#' Split Dataframe by Subgroups
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Split a dataframe into a non-nested list of subsets.
#'
#' @details Main functionality is to prepare data for use in forest plot layouts.
#'
#' @inheritParams survival_duration_subgroups
#' @param data (`data.frame`)\cr dataset to split.
#' @param subgroups (`character`)\cr names of factor variables from `data` used to create subsets.
#'   Unused levels not present in `data` are dropped. Note that the order in this vector
#'   determines the order in the downstream table.
#'
#' @return A list with subset data (`df`) and metadata about the subset (`df_labels`).
#'
#' @examples
#' df <- data.frame(
#'   x = c(1:5),
#'   y = factor(c("A", "B", "A", "B", "A"), levels = c("A", "B", "C")),
#'   z = factor(c("C", "C", "D", "D", "D"), levels = c("D", "C"))
#' )
#' formatters::var_labels(df) <- paste("label for", names(df))
#'
#' h_split_by_subgroups(
#'   data = df,
#'   subgroups = c("y", "z")
#' )
#'
#' h_split_by_subgroups(
#'   data = df,
#'   subgroups = c("y", "z"),
#'   groups_lists = list(
#'     y = list("AB" = c("A", "B"), "C" = "C")
#'   )
#' )
#'
#' @export
h_split_by_subgroups <- function(data,
                                 subgroups,
                                 groups_lists = list()) {
  checkmate::assert_character(subgroups, min.len = 1, any.missing = FALSE)
  checkmate::assert_list(groups_lists, names = "named")
  checkmate::assert_subset(names(groups_lists), subgroups)
  assert_df_with_factors(data, as.list(stats::setNames(subgroups, subgroups)))

  data_labels <- unname(formatters::var_labels(data))
  df_subgroups <- data[, subgroups, drop = FALSE]
  subgroup_labels <- formatters::var_labels(df_subgroups, fill = TRUE)

  l_labels <- Map(function(grp_i, name_i) {
    existing_levels <- levels(droplevels(grp_i))
    grp_levels <- if (name_i %in% names(groups_lists)) {
      # For this variable groupings are defined. We check which groups are contained in the data.
      group_list_i <- groups_lists[[name_i]]
      group_has_levels <- vapply(group_list_i, function(lvls) any(lvls %in% existing_levels), TRUE)
      names(which(group_has_levels))
    } else {
      existing_levels
    }
    df_labels <- data.frame(
      subgroup = grp_levels,
      var = name_i,
      var_label = unname(subgroup_labels[name_i]),
      stringsAsFactors = FALSE # Rationale is that subgroups may not be unique.
    )
  }, df_subgroups, names(df_subgroups))

  # Create a dataframe with one row per subgroup.
  df_labels <- do.call(rbind, args = c(l_labels, make.row.names = FALSE))
  row_label <- paste0(df_labels$var, ".", df_labels$subgroup)
  row_split_var <- factor(row_label, levels = row_label)

  # Create a list of data subsets.
  lapply(split(df_labels, row_split_var), function(row_i) {
    which_row <- if (row_i$var %in% names(groups_lists)) {
      data[[row_i$var]] %in% groups_lists[[row_i$var]][[row_i$subgroup]]
    } else {
      data[[row_i$var]] == row_i$subgroup
    }
    df <- data[which_row, ]
    rownames(df) <- NULL
    formatters::var_labels(df) <- data_labels

    list(
      df = df,
      df_labels = data.frame(row_i, row.names = NULL)
    )
  })
}

#' Summarize Variables in Columns
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This Analyze Function uses the new S3 generic function [s_summary()] to summarize
#' different variables that are arranged in columns.
#' Additional standard formatting arguments are available.
#'
#' @inheritParams argument_convention
#' @param ... arguments passed to `s_summary()`.
#'
#' @seealso [rtables::split_cols_by_multivar()]
#'
#' @template formatting_arguments
#'
#' @export
#' @examples
#'
#' dta_test <- data.frame(
#'   USUBJID = rep(1:6, each = 3),
#'   PARAMCD = rep("lab", 6 * 3),
#'   AVISIT = rep(paste0("V", 1:3), 6),
#'   ARM = rep(LETTERS[1:3], rep(6, 3)),
#'   AVAL = c(9:1, rep(NA, 9)),
#'   CHG = c(1:9, rep(NA, 9))
#' )
#'
#' ## Default output within a `rtables` pipeline.
#' basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_rows_by("AVISIT") %>%
#'   split_cols_by_multivar(vars = c("AVAL", "CHG")) %>%
#'   summarize_colvars() %>%
#'   build_table(dta_test)
#'
#' ## Selection of statistics, formats and labels also work.
#' basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_rows_by("AVISIT") %>%
#'   split_cols_by_multivar(vars = c("AVAL", "CHG")) %>%
#'   summarize_colvars(
#'     .stats = c("n", "mean_sd"),
#'     .formats = c("mean_sd" = "xx.x, xx.x"),
#'     .labels = c(n = "n", mean_sd = "Mean, SD")
#'   ) %>%
#'   build_table(dta_test)
#'
#' ## Use arguments interpreted by `s_summary`.
#' basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_rows_by("AVISIT") %>%
#'   split_cols_by_multivar(vars = c("AVAL", "CHG")) %>%
#'   summarize_colvars(na.rm = FALSE) %>%
#'   build_table(dta_test)
summarize_colvars <- function(lyt,
                              ...,
                              .stats = c("n", "mean_sd", "median", "range", "count_fraction"),
                              .formats = NULL,
                              .labels = NULL,
                              .indent_mods = NULL) {
  afun <- create_afun_summary(.stats, .formats, .labels, .indent_mods)

  analyze_colvars(
    lyt,
    afun = afun,
    extra_args = list(...)
  )
}

#' Subgroup Treatment Effect Pattern (STEP) Fit for Binary (Response) Outcome
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This fits the Subgroup Treatment Effect Pattern logistic regression models for a binary
#' (response) outcome. The treatment arm variable must have exactly 2 levels,
#' where the first one is taken as reference and the estimated odds ratios are
#' for the comparison of the second level vs. the first one.
#'
#' The (conditional) logistic regression model which is fit is:
#'
#' `response ~ arm * poly(biomarker, degree) + covariates + strata(strata)`
#'
#' where `degree` is specified by `control_step()`.
#' Note that for the default degree 0 the `biomarker` variable is not included in the model.
#'
#' @inheritParams argument_convention
#' @param variables (named `list` of `character`)\cr list of analysis variables:
#'   needs `response`, `arm`, `biomarker`, and optional `covariates` and
#'   `strata`.
#' @param control (named `list`)\cr combined control list from [control_step()]
#'   and [control_logistic()].
#' @return a matrix of class `step`. The first part of the columns describe the
#'   subgroup intervals used for the biomarker variable, including where the
#'   center of the intervals are and their bounds. The second part of the
#'   columns contain the estimates for the treatment arm comparison.
#' @seealso [control_step()] and [control_logistic()] for the available
#'   customization options.
#' @export
#'
#' @examples
#' # Testing dataset with just two treatment arms.
#' library(survival)
#' library(dplyr)
#'
#' adrs_f <- tern_ex_adrs %>%
#'   filter(
#'     PARAMCD == "BESRSPI",
#'     ARM %in% c("B: Placebo", "A: Drug X")
#'   ) %>%
#'   mutate(
#'     # Reorder levels of ARM to have Placebo as reference arm for Odds Ratio calculations.
#'     ARM = droplevels(forcats::fct_relevel(ARM, "B: Placebo")),
#'     RSP = case_when(AVALC %in% c("PR", "CR") ~ 1, TRUE ~ 0),
#'     SEX = factor(SEX)
#'   )
#'
#' variables <- list(
#'   arm = "ARM",
#'   biomarker = "BMRKR1",
#'   covariates = "AGE",
#'   response = "RSP"
#' )
#'
#' # Fit default STEP models: Here a constant treatment effect is estimated in each subgroup.
#' # We use a large enough bandwidth to avoid too small subgroups and linear separation in those.
#' step_matrix <- fit_rsp_step(
#'   variables = variables,
#'   data = adrs_f,
#'   control = c(control_logistic(), control_step(bandwidth = 0.5))
#' )
#' dim(step_matrix)
#' head(step_matrix)
#'
#' # Specify different polynomial degree for the biomarker interaction to use more flexible local
#' # models. Or specify different logistic regression options, including confidence level.
#' step_matrix2 <- fit_rsp_step(
#'   variables = variables,
#'   data = adrs_f,
#'   control = c(control_logistic(conf_level = 0.9), control_step(bandwidth = 0.6, degree = 1))
#' )
#'
#' # Use a global constant model. This is helpful as a reference for the subgroup models.
#' step_matrix3 <- fit_rsp_step(
#'   variables = variables,
#'   data = adrs_f,
#'   control = c(control_logistic(), control_step(bandwidth = NULL, num_points = 2L))
#' )
#'
#' # It is also possible to use strata, i.e. use conditional logistic regression models.
#' variables2 <- list(
#'   arm = "ARM",
#'   biomarker = "BMRKR1",
#'   covariates = "AGE",
#'   response = "RSP",
#'   strata = c("STRATA1", "STRATA2")
#' )
#'
#' step_matrix4 <- fit_rsp_step(
#'   variables = variables2,
#'   data = adrs_f,
#'   control = c(control_logistic(), control_step(bandwidth = 0.6))
#' )
fit_rsp_step <- function(variables,
                         data,
                         control = c(control_step(), control_logistic())) {
  assert_df_with_variables(data, variables)
  checkmate::assert_list(control, names = "named")
  data <- data[!is.na(data[[variables$biomarker]]), ]
  window_sel <- h_step_window(x = data[[variables$biomarker]], control = control)
  interval_center <- window_sel$interval[, "Interval Center"]
  form <- h_step_rsp_formula(variables = variables, control = control)
  estimates <- if (is.null(control$bandwidth)) {
    h_step_rsp_est(
      formula = form,
      data = data,
      variables = variables,
      x = interval_center,
      control = control
    )
  } else {
    tmp <- mapply(
      FUN = h_step_rsp_est,
      x = interval_center,
      subset = as.list(as.data.frame(window_sel$sel)),
      MoreArgs = list(
        formula = form,
        data = data,
        variables = variables,
        control = control
      )
    )
    # Maybe we find a more elegant solution than this.
    rownames(tmp) <- c("n", "logor", "se", "ci_lower", "ci_upper")
    t(tmp)
  }
  result <- cbind(window_sel$interval, estimates)
  structure(
    result,
    class = c("step", "matrix"),
    variables = variables,
    control = control
  )
}

#' Multi-Variable Logistic Regression Table
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Layout creating function which summarizes a logistic variable regression for binary outcome with
#' categorical/continuous covariates in model statement. For each covariate category (if categorical)
#' or specified values (if continuous), present degrees of freedom, regression parameter estimate and
#' standard error (SE) relative to reference group or category. Report odds ratios for each covariate
#' category or specified values and corresponding Wald confidence intervals as default but allow user
#' to specify other confidence levels. Report p-value for Wald chi-square test of the null hypothesis
#' that covariate has no effect on response in model containing all specified covariates.
#' Allow option to include one two-way interaction and present similar output for
#' each interaction degree of freedom.
#' Note: For the formula, the variable names need to be standard dataframe column name without
#' special characters.
#'
#' @inheritParams argument_convention
#' @param drop_and_remove_str string to be dropped and removed
#'
#' @examples
#' library(dplyr)
#' library(broom)
#'
#' adrs_f <- tern_ex_adrs %>%
#'   filter(PARAMCD == "BESRSPI") %>%
#'   filter(RACE %in% c("ASIAN", "WHITE", "BLACK OR AFRICAN AMERICAN")) %>%
#'   mutate(
#'     Response = case_when(AVALC %in% c("PR", "CR") ~ 1, TRUE ~ 0),
#'     RACE = factor(RACE),
#'     SEX = factor(SEX)
#'   )
#' formatters::var_labels(adrs_f) <- c(formatters::var_labels(tern_ex_adrs), Response = "Response")
#' mod1 <- fit_logistic(
#'   data = adrs_f,
#'   variables = list(
#'     response = "Response",
#'     arm = "ARMCD",
#'     covariates = c("AGE", "RACE")
#'   )
#' )
#' mod2 <- fit_logistic(
#'   data = adrs_f,
#'   variables = list(
#'     response = "Response",
#'     arm = "ARMCD",
#'     covariates = c("AGE", "RACE"),
#'     interaction = "AGE"
#'   )
#' )
#'
#' df <- tidy(mod1, conf_level = 0.99)
#' df2 <- tidy(mod2, conf_level = 0.99)
#'
#' # flagging empty strings with "_"
#' df <- df_explicit_na(df, na_level = "_")
#' df2 <- df_explicit_na(df2, na_level = "_")
#'
#' result1 <- basic_table() %>%
#'   summarize_logistic(
#'     conf_level = 0.95,
#'     drop_and_remove_str = "_"
#'   ) %>%
#'   build_table(df = df)
#' result1
#'
#' result2 <- basic_table() %>%
#'   summarize_logistic(
#'     conf_level = 0.95,
#'     drop_and_remove_str = "_"
#'   ) %>%
#'   build_table(df = df2)
#' result2
#'
#' @export
summarize_logistic <- function(lyt,
                               conf_level,
                               drop_and_remove_str = "") {
  # checks
  checkmate::assert_string(drop_and_remove_str)

  sum_logistic_variable_test <- logistic_summary_by_flag("is_variable_summary")
  sum_logistic_term_estimates <- logistic_summary_by_flag("is_term_summary")
  sum_logistic_odds_ratios <- logistic_summary_by_flag("is_reference_summary")
  split_fun <- drop_and_remove_levels(drop_and_remove_str)

  lyt <- logistic_regression_cols(lyt, conf_level = conf_level)
  lyt <- split_rows_by(lyt, var = "variable", labels_var = "variable_label", split_fun = split_fun)
  lyt <- sum_logistic_variable_test(lyt)
  lyt <- split_rows_by(lyt, var = "term", labels_var = "term_label", split_fun = split_fun)
  lyt <- sum_logistic_term_estimates(lyt)
  lyt <- split_rows_by(lyt, var = "interaction", labels_var = "interaction_label", split_fun = split_fun)
  lyt <- split_rows_by(lyt, var = "reference", labels_var = "reference_label", split_fun = split_fun)
  lyt <- sum_logistic_odds_ratios(lyt)
  lyt
}

#' Fit for Logistic Regression
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Fit a (conditional) logistic regression model.
#'
#' @inheritParams argument_convention
#' @param data (`data.frame`)\cr the data frame on which the model was fit.
#' @param response_definition (`string`)\cr the definition of what an event is in terms of `response`.
#'   This will be used when fitting the (conditional) logistic regression model on the left hand
#'   side of the formula.
#'
#' @section Model Specification:
#'
#' The `variables` list needs to include the following elements:
#' \describe{
#'   \item{arm}{treatment arm variable name.}
#'   \item{response}{the response arm variable name. Usually this is a 0/1 variable.}
#'   \item{covariates}{this is either `NULL` (no covariates) or a character vector of covariate variable names.}
#'   \item{interaction}{this is either `NULL` (no interaction) or a string of a single covariate variable name already
#'     included in `covariates`. Then the interaction with the treatment arm is included in the model.
#'   }
#' }
#'
#' @examples
#' library(dplyr)
#'
#' adrs_f <- tern_ex_adrs %>%
#'   filter(PARAMCD == "BESRSPI") %>%
#'   filter(RACE %in% c("ASIAN", "WHITE", "BLACK OR AFRICAN AMERICAN")) %>%
#'   mutate(
#'     Response = case_when(AVALC %in% c("PR", "CR") ~ 1, TRUE ~ 0),
#'     RACE = factor(RACE),
#'     SEX = factor(SEX)
#'   )
#' formatters::var_labels(adrs_f) <- c(formatters::var_labels(tern_ex_adrs), Response = "Response")
#' mod1 <- fit_logistic(
#'   data = adrs_f,
#'   variables = list(
#'     response = "Response",
#'     arm = "ARMCD",
#'     covariates = c("AGE", "RACE")
#'   )
#' )
#' mod2 <- fit_logistic(
#'   data = adrs_f,
#'   variables = list(
#'     response = "Response",
#'     arm = "ARMCD",
#'     covariates = c("AGE", "RACE"),
#'     interaction = "AGE"
#'   )
#' )
#'
#' @export
fit_logistic <- function(data,
                         variables = list(
                           response = "Response",
                           arm = "ARMCD",
                           covariates = NULL,
                           interaction = NULL,
                           strata = NULL
                         ),
                         response_definition = "response") {
  assert_df_with_variables(data, variables)
  checkmate::assert_subset(names(variables), c("response", "arm", "covariates", "interaction", "strata"))
  checkmate::assert_string(response_definition)
  checkmate::assert_true(grepl("response", response_definition))

  response_definition <- sub(
    pattern = "response",
    replacement = variables$response,
    x = response_definition,
    fixed = TRUE
  )
  form <- paste0(response_definition, " ~ ", variables$arm)
  if (!is.null(variables$covariates)) {
    form <- paste0(form, " + ", paste(variables$covariates, collapse = " + "))
  }
  if (!is.null(variables$interaction)) {
    checkmate::assert_string(variables$interaction)
    checkmate::assert_subset(variables$interaction, variables$covariates)
    form <- paste0(form, " + ", variables$arm, ":", variables$interaction)
  }
  if (!is.null(variables$strata)) {
    strata_arg <- if (length(variables$strata) > 1) {
      paste0("I(interaction(", paste0(variables$strata, collapse = ", "), "))")
    } else {
      variables$strata
    }
    form <- paste0(form, "+ strata(", strata_arg, ")")
  }
  formula <- stats::as.formula(form)
  if (is.null(variables$strata)) {
    stats::glm(
      formula = formula,
      data = data,
      family = stats::binomial("logit")
    )
  } else {
    clogit_with_tryCatch(
      formula = formula,
      data = data,
      x = TRUE
    )
  }
}

#' Custom Tidy Method for Binomial GLM Results
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Helper method (for [broom::tidy()]) to prepare a data frame from a `glm` object
#' with `binomial` family.
#'
#' @inheritParams argument_convention
#' @param at (`NULL` or `numeric`)\cr optional values for the interaction variable. Otherwise
#'   the median is used.
#' @param fit_glm logistic regression model fitted by [stats::glm()] with "binomial" family.
#' @method tidy glm
#' @seealso [h_logistic_regression] for relevant helper functions.
#'
#' @examples
#' library(dplyr)
#' library(broom)
#'
#' adrs_f <- tern_ex_adrs %>%
#'   filter(PARAMCD == "BESRSPI") %>%
#'   filter(RACE %in% c("ASIAN", "WHITE", "BLACK OR AFRICAN AMERICAN")) %>%
#'   mutate(
#'     Response = case_when(AVALC %in% c("PR", "CR") ~ 1, TRUE ~ 0),
#'     RACE = factor(RACE),
#'     SEX = factor(SEX)
#'   )
#' formatters::var_labels(adrs_f) <- c(formatters::var_labels(tern_ex_adrs), Response = "Response")
#' mod1 <- fit_logistic(
#'   data = adrs_f,
#'   variables = list(
#'     response = "Response",
#'     arm = "ARMCD",
#'     covariates = c("AGE", "RACE")
#'   )
#' )
#' mod2 <- fit_logistic(
#'   data = adrs_f,
#'   variables = list(
#'     response = "Response",
#'     arm = "ARMCD",
#'     covariates = c("AGE", "RACE"),
#'     interaction = "AGE"
#'   )
#' )
#'
#' df <- tidy(mod1, conf_level = 0.99)
#' df2 <- tidy(mod2, conf_level = 0.99)
#'
#' @export
tidy.glm <- function(fit_glm, # nolint
                     conf_level = 0.95,
                     at = NULL) {
  checkmate::assert_class(fit_glm, "glm")
  checkmate::assert_set_equal(fit_glm$family$family, "binomial")

  terms_name <- attr(stats::terms(fit_glm), "term.labels")
  xs_class <- attr(fit_glm$terms, "dataClasses")
  interaction <- terms_name[which(!terms_name %in% names(xs_class))]
  df <- if (length(interaction) == 0) {
    h_logistic_simple_terms(
      x = terms_name,
      fit_glm = fit_glm,
      conf_level = conf_level
    )
  } else {
    h_logistic_inter_terms(
      x = terms_name,
      fit_glm = fit_glm,
      conf_level = conf_level,
      at = at
    )
  }
  for (var in c("variable", "term", "interaction", "reference")) {
    df[[var]] <- factor(df[[var]], levels = unique(df[[var]]))
  }
  df
}

#' Logistic Regression Multi-Variable Column Layout Function
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Layout creating function for a multi-variable column layout summarizing
#' logistic regression results.
#'
#' @inheritParams argument_convention
#'
#' @export
logistic_regression_cols <- function(lyt,
                                     conf_level = 0.95) {
  vars <- c("df", "estimate", "std_error", "odds_ratio", "ci", "pvalue")
  var_labels <- c(
    df = "Degrees of Freedom",
    estimate = "Parameter Estimate",
    std_error = "Standard Error",
    odds_ratio = "Odds Ratio",
    ci = paste("Wald", f_conf_level(conf_level)),
    pvalue = "p-value"
  )
  split_cols_by_multivar(
    lyt = lyt,
    vars = vars,
    varlabels = var_labels
  )
}

#' Logistic Regression Summary Table Constructor Function
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Constructor for content functions to be used to summarize
#' logistic regression results.
#'
#' @param flag_var (`string`)\cr variable name identifying which row should be used in this
#'   content function.
#'
#' @export
logistic_summary_by_flag <- function(flag_var) {
  checkmate::assert_string(flag_var)
  function(lyt) {
    cfun_list <- list(
      df = cfun_by_flag("df", flag_var, format = "xx."),
      estimate = cfun_by_flag("estimate", flag_var, format = "xx.xxx"),
      std_error = cfun_by_flag("std_error", flag_var, format = "xx.xxx"),
      odds_ratio = cfun_by_flag("odds_ratio", flag_var, format = ">999.99"),
      ci = cfun_by_flag("ci", flag_var, format = format_extreme_values_ci(2L)),
      pvalue = cfun_by_flag("pvalue", flag_var, format = "x.xxxx | (<0.0001)")
    )
    summarize_row_groups(
      lyt = lyt,
      cfun = cfun_list
    )
  }
}

#' Control Function for Descriptive Statistics
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Sets a list of parameters for summaries of descriptive statistics. Typically used internally to specify
#' details for [s_summary].
#'
#' @inheritParams argument_convention
#' @param quantiles (`numeric`)\cr of length two to specify the quantiles to calculate.
#' @param quantile_type (`numeric`)\cr between 1 and 9 selecting quantile algorithms to be used.
#'   Default is set to 2 as this matches the default quantile algorithm in SAS `proc univariate` set by `QNTLDEF=5`.
#'   This differs from R's default. See more about `type` in [stats::quantile()].
#' @param test_mean (`numeric`)\cr to test against the mean under the null hypothesis when calculating p-value.
#'
#' @return A list of components with the same names as the arguments.
#' @export
#'
control_summarize_vars <- function(conf_level = 0.95,
                                   quantiles = c(0.25, 0.75),
                                   quantile_type = 2,
                                   test_mean = 0) {
  checkmate::assert_vector(quantiles, len = 2)
  checkmate::assert_int(quantile_type, lower = 1, upper = 9)
  checkmate::assert_numeric(test_mean)
  nullo <- lapply(quantiles, assert_proportion_value)
  assert_proportion_value(conf_level)
  list(conf_level = conf_level, quantiles = quantiles, quantile_type = quantile_type, test_mean = test_mean)
}

#' Format Function for Descriptive Statistics
#'
#' @description
#'
#' Returns format patterns for descriptive statistics.
#' The format is understood by the `rtables`.
#'
#' @param type (`string`)\cr choice of a summary data type.
#' Only `counts` and `numeric` types are currently supported.
#'
#' @keywords internal
summary_formats <- function(type = "numeric") {
  if (type == "counts") {
    c(
      n = "xx.",
      count = "xx.",
      count_fraction = format_count_fraction,
      n_blq = "xx."
    )
  } else {
    c(
      n = "xx.",
      sum = "xx.x",
      mean = "xx.x",
      sd = "xx.x",
      se = "xx.x",
      mean_sd = "xx.x (xx.x)",
      mean_se = "xx.x (xx.x)",
      mean_ci = "(xx.xx, xx.xx)",
      mean_sei = "(xx.xx, xx.xx)",
      mean_sdi = "(xx.xx, xx.xx)",
      mean_pval = "xx.xx",
      median = "xx.x",
      mad = "xx.x",
      median_ci = "(xx.xx, xx.xx)",
      quantiles = "xx.x - xx.x",
      iqr = "xx.x",
      range = "xx.x - xx.x",
      cv = "xx.x",
      min = "xx.x",
      max = "xx.x",
      geom_mean = "xx.x",
      geom_cv = "xx.x"
    )
  }
}

#' Label Function for Descriptive Statistics
#'
#' @description
#'
#' Returns labels of descriptive statistics for numeric variables.
#'
#' @keywords internal
summary_labels <- function() {
  c(
    mean = "Mean",
    sum = "Sum",
    sd = "SD",
    se = "SE",
    mean_sd = "Mean (SD)",
    mean_se = "Mean (SE)",
    median = "Median",
    mad = "Median Absolute Deviation",
    iqr = "IQR",
    range = "Min - Max",
    cv = "CV (%)",
    min = "Minimum",
    max = "Maximum",
    geom_mean = "Geometric Mean",
    geom_cv = "CV % Geometric Mean",
    n = "n"
  )
}

#' Summarize Variables
#'
#' @description `r lifecycle::badge("stable")`
#'
#' We use the new S3 generic function [s_summary()] to implement summaries for
#' different `x` objects. This is used as Statistics Function in combination
#' with the new Analyze Function [summarize_vars()].
#'
#' @name summarize_variables
NULL

#' @inheritParams argument_convention
#'
#' @describeIn summarize_variables `s_summary` is a S3 generic function to produce
#'   an object description.
#'
#' @export
s_summary <- function(x,
                      na.rm = TRUE, # nolint
                      denom,
                      .N_row, # nolint
                      .N_col, # nolint
                      na_level,
                      .var,
                      ...) {
  checkmate::assert_flag(na.rm)
  UseMethod("s_summary", x)
}

#' @describeIn summarize_variables Method for numeric class. Note that,
#'   if `x` is an empty vector, `NA` is returned. This is the expected
#'   feature so as to return `rcell` content in `rtables` when the
#'   intersection of a column and a row delimits an empty data selection.
#'   Also, when the `mean` function is applied to an empty vector, `NA` will
#'   be returned instead of `NaN`, the latter being standard behavior in R.
#'
#' @param control (`list`)\cr parameters for descriptive statistics details, specified by using
#'   the helper function [control_summarize_vars()]. Some possible parameter options are:
#'   * `conf_level` (`proportion`)\cr confidence level of the interval for mean and median.
#'   * `quantiles` (`numeric`)\cr vector of length two to specify the quantiles.
#'   * `quantile_type` (`numeric`)\cr between 1 and 9 selecting quantile algorithms to be used.
#'     See more about `type` in [stats::quantile()].
#'   * `test_mean` (`numeric`)\cr value to test against the mean under the null hypothesis when calculating p-value.
#'
#' @return If `x` is of class `numeric`, returns a list with the following named `numeric` items:
#' \describe{
#'   \item{n}{the [length()] of `x`.}
#'   \item{sum}{the [sum()] of `x`.}
#'   \item{mean}{the [mean()] of `x`.}
#'   \item{sd}{the [stats::sd()] of `x`.}
#'   \item{se}{the standard error of `x` mean, i.e.: (`sd(x) / sqrt(length(x))`).}
#'   \item{mean_sd}{the [mean()] and [stats::sd()] of `x`.}
#'   \item{mean_se}{the [mean()] of `x` and its standard error (see above).}
#'   \item{mean_ci}{the CI for the mean of `x` (from [stat_mean_ci()]).}
#'   \item{mean_sei}{the SE interval for the mean of `x`, i.e.: ([mean()] -/+ [stats::sd()] / [sqrt()]).}
#'   \item{mean_sdi}{the SD interval for the mean of `x`, i.e.: ([mean()] -/+ [stats::sd()]).}
#'   \item{mean_pval}{the two-sided p-value of the mean of `x` (from [stat_mean_pval()]).}
#'   \item{median}{the [stats::median()] of `x`.}
#'   \item{mad}{the median absolute deviation of `x`, i.e.: ([stats::median()] of `xc`,
#'     where `xc` = `x` - [stats::median()]).
#'   }
#'   \item{median_ci}{the CI for the median of `x` (from [stat_median_ci()]).}
#'   \item{quantiles}{two sample quantiles of `x` (from [stats::quantile()]).}
#'   \item{iqr}{the [stats::IQR()] of `x`.}
#'   \item{range}{the [range_noinf()] of `x`.}
#'   \item{min}{the [max()] of `x`.}
#'   \item{max}{the [min()] of `x`.}
#'   \item{cv}{the coefficient of variation of `x`, i.e.: ([stats::sd()] / [mean()] * 100).}
#'   \item{geom_mean}{the geometric mean of `x`, i.e.: (`exp(mean(log(x)))`).}
#'   \item{geom_cv}{the geometric coefficient of variation of `x`, i.e.: (`sqrt(exp(sd(log(x)) ^ 2) - 1) * 100`).}
#' }
#' @method s_summary numeric
#'
#' @examples
#' # `s_summary.numeric`
#'
#' ## Basic usage: empty numeric returns NA-filled items.
#' s_summary(numeric())
#'
#' ## Management of NA values.
#' x <- c(NA_real_, 1)
#' s_summary(x, na.rm = TRUE)
#' s_summary(x, na.rm = FALSE)
#'
#' x <- c(NA_real_, 1, 2)
#' s_summary(x, stats = NULL)
#'
#' ## Benefits in `rtables` contructions:
#' require(rtables)
#' dta_test <- data.frame(
#'   Group = rep(LETTERS[1:3], each = 2),
#'   sub_group = rep(letters[1:2], each = 3),
#'   x = 1:6
#' )
#'
#' ## The summary obtained in with `rtables`:
#' basic_table() %>%
#'   split_cols_by(var = "Group") %>%
#'   split_rows_by(var = "sub_group") %>%
#'   analyze(vars = "x", afun = s_summary) %>%
#'   build_table(df = dta_test)
#'
#' ## By comparison with `lapply`:
#' X <- split(dta_test, f = with(dta_test, interaction(Group, sub_group)))
#' lapply(X, function(x) s_summary(x$x))
#'
#' @export
s_summary.numeric <- function(x, # nolint
                              na.rm = TRUE, # nolint
                              denom,
                              .N_row, # nolint
                              .N_col, # nolint
                              na_level,
                              .var,
                              control = control_summarize_vars(),
                              ...) {
  checkmate::assert_numeric(x)

  if (na.rm) {
    x <- x[!is.na(x)]
  }

  y <- list()

  y$n <- c("n" = length(x))

  y$sum <- c("sum" = ifelse(length(x) == 0, NA_real_, sum(x, na.rm = FALSE)))

  y$mean <- c("mean" = ifelse(length(x) == 0, NA_real_, mean(x, na.rm = FALSE)))

  y$sd <- c("sd" = stats::sd(x, na.rm = FALSE))

  y$se <- c("se" = stats::sd(x, na.rm = FALSE) / sqrt(length(stats::na.omit(x))))

  y$mean_sd <- c(y$mean, "sd" = stats::sd(x, na.rm = FALSE))

  y$mean_se <- c(y$mean, y$se)

  mean_ci <- stat_mean_ci(x, conf_level = control$conf_level, na.rm = FALSE, gg_helper = FALSE)
  y$mean_ci <- formatters::with_label(mean_ci, paste("Mean", f_conf_level(control$conf_level)))

  mean_sei <- y$mean[[1]] + c(-1, 1) * stats::sd(x, na.rm = FALSE) / sqrt(y$n)
  names(mean_sei) <- c("mean_sei_lwr", "mean_sei_upr")
  y$mean_sei <- formatters::with_label(mean_sei, "Mean -/+ 1xSE")

  mean_sdi <- y$mean[[1]] + c(-1, 1) * stats::sd(x, na.rm = FALSE)
  names(mean_sdi) <- c("mean_sdi_lwr", "mean_sdi_upr")
  y$mean_sdi <- formatters::with_label(mean_sdi, "Mean -/+ 1xSD")

  mean_pval <- stat_mean_pval(x, test_mean = control$test_mean, na.rm = FALSE, n_min = 2)
  y$mean_pval <- formatters::with_label(mean_pval, paste("Mean", f_pval(control$test_mean)))

  y$median <- c("median" = stats::median(x, na.rm = FALSE))

  y$mad <- c("mad" = stats::median(x - y$median, na.rm = FALSE))

  median_ci <- stat_median_ci(x, conf_level = control$conf_level, na.rm = FALSE, gg_helper = FALSE)
  y$median_ci <- formatters::with_label(median_ci, paste("Median", f_conf_level(control$conf_level)))

  q <- control$quantiles
  if (any(is.na(x))) {
    qnts <- rep(NA_real_, length(q))
  } else {
    qnts <- stats::quantile(x, probs = q, type = control$quantile_type, na.rm = FALSE)
  }
  names(qnts) <- paste("quantile", q, sep = "_")
  y$quantiles <- formatters::with_label(qnts, paste0(paste(paste0(q * 100, "%"), collapse = " and "), "-ile"))

  y$iqr <- c("iqr" = ifelse(
    any(is.na(x)),
    NA_real_,
    stats::IQR(x, na.rm = FALSE, type = control$quantile_type)
  ))

  y$range <- stats::setNames(range_noinf(x, na.rm = FALSE), c("min", "max"))
  y$min <- y$range[1]
  y$max <- y$range[2]

  y$cv <- c("cv" = unname(y$sd) / unname(y$mean) * 100)

  # Convert negative values to NA for log calculation.
  x_no_negative_vals <- x
  x_no_negative_vals[x_no_negative_vals <= 0] <- NA
  y$geom_mean <- c("geom_mean" = exp(mean(log(x_no_negative_vals), na.rm = FALSE)))
  geom_mean_ci <- stat_mean_ci(x, conf_level = control$conf_level, na.rm = FALSE, gg_helper = FALSE, geom_mean = TRUE)
  y$geom_mean_ci <- formatters::with_label(geom_mean_ci, paste("Geometric Mean", f_conf_level(control$conf_level)))

  y$geom_cv <- c("geom_cv" = sqrt(exp(stats::sd(log(x_no_negative_vals), na.rm = FALSE) ^ 2) - 1) * 100) # styler: off

  y
}

#' @describeIn summarize_variables Method for factor class. Note that,
#'   if `x` is an empty factor, then still a list is returned for `counts` with one element
#'   per factor level. If there are no levels in `x`, the function fails. If `x` contains `NA`,
#'   it is expected that `NA` have been conveyed to `na_level` appropriately beforehand with
#'   [df_explicit_na()] or [explicit_na()].
#'
#' @param denom (`string`)\cr choice of denominator for factor proportions. Options are:
#'   - `n`: number of values in this row and column intersection.
#'   - `N_row`: total number of values in this row across columns.
#'   - `N_col`: total number of values in this column across rows.
#'
#' @return If `x` is of class `factor` or converted from `character`, returns a list with named `numeric` items:
#' \describe{
#'   \item{n}{the [length()] of `x`.}
#'   \item{count}{a list with the number of cases for each level of the factor `x`.}
#'   \item{count_fraction}{similar to `count` but also includes the proportion of cases for each level of the
#'     factor `x` relative to the denominator, or `NA` if the denominator is zero.
#'   }
#' }
#' @method s_summary factor
#'
#' @examples
#' # `s_summary.factor`
#'
#' ## Basic usage:
#' s_summary(factor(c("a", "a", "b", "c", "a")))
#' # Empty factor returns NA-filled items.
#' s_summary(factor(levels = c("a", "b", "c")))
#'
#' ## Management of NA values.
#' x <- factor(c(NA, "Female"))
#' x <- explicit_na(x)
#' s_summary(x, na.rm = TRUE)
#' s_summary(x, na.rm = FALSE)
#'
#' ## Different denominators.
#' x <- factor(c("a", "a", "b", "c", "a"))
#' s_summary(x, denom = "N_row", .N_row = 10L)
#' s_summary(x, denom = "N_col", .N_col = 20L)
#'
#' @export
s_summary.factor <- function(x,
                             na.rm = TRUE, # nolint
                             denom = c("n", "N_row", "N_col"),
                             .N_row, # nolint
                             .N_col, # nolint
                             na_level = "<Missing>",
                             ...) {
  assert_valid_factor(x, any.missing = FALSE)
  denom <- match.arg(denom)

  if (na.rm) x <- fct_discard(x, na_level)

  y <- list()

  y$n <- length(x)

  y$count <- as.list(table(x, useNA = "ifany"))
  dn <- switch(denom,
    n = length(x),
    N_row = .N_row,
    N_col = .N_col
  )
  y$count_fraction <- lapply(
    y$count,
    function(x) {
      c(x, ifelse(dn > 0, x / dn, 0))
    }
  )

  y$n_blq <- sum(grepl("BLQ|LTR|<[1-9]", x)) # nolint

  y
}

#' @describeIn summarize_variables Method for character class. This makes an automatic
#'   conversion to factor (with a warning) and then forwards to the method for factors.
#' @param verbose defaults to `TRUE`. It prints out warnings and messages. It is mainly used
#'   to print out information about factor casting.
#' @note Automatic conversion of character to factor does not guarantee that the table
#'   can be generated correctly. In particular for sparse tables this very likely can fail.
#'   It is therefore better to always pre-process the dataset such that factors are manually
#'   created from character variables before passing the dataset to [rtables::build_table()].
#' @method s_summary character
#'
#' @export
#'
#' @examples
#' # `s_summary.character`
#'
#' ## Basic usage:
#' s_summary(c("a", "a", "b", "c", "a"), .var = "x", verbose = FALSE)
#' s_summary(c("a", "a", "b", "c", "a", ""), .var = "x", na.rm = FALSE, verbose = FALSE)
s_summary.character <- function(x,
                                na.rm = TRUE, # nolint
                                denom = c("n", "N_row", "N_col"),
                                .N_row, # nolint
                                .N_col, # nolint
                                na_level = "<Missing>",
                                .var,
                                verbose = TRUE,
                                ...) {
  y <- as_factor_keep_attributes(x, x_name = .var, na_level = na_level, verbose = verbose)
  s_summary(
    x = y,
    na.rm = na.rm,
    na_level = na_level,
    denom = denom,
    .N_row = .N_row,
    .N_col = .N_col,
    ...
  )
}

#' @describeIn summarize_variables Method for logical class.
#'
#' @param denom (`string`)\cr choice of denominator for proportion. Options are:
#'   - `n`: number of values in this row and column intersection.
#'   - `N_row`: total number of values in this row across columns.
#'   - `N_col`: total number of values in this column across rows.
#'
#' @return If `x` is of class `logical`, returns a list with named `numeric` items:
#' \describe{
#'   \item{n}{the [length()] of `x` (possibly after removing `NA`s).}
#'   \item{count}{count of `TRUE` in `x`.}
#'   \item{count_fraction}{count and proportion of `TRUE` in `x` relative to the denominator, or `NA` if the
#'     denominator is zero. Note that `NA`s in `x` are never counted or leading to `NA` here.
#'   }
#' }
#' @method s_summary logical
#'
#' @examples
#' # `s_summary.logical`
#'
#' ## Basic usage:
#' s_summary(c(TRUE, FALSE, TRUE, TRUE))
#'
#' ## Management of NA values.
#' x <- c(NA, TRUE, FALSE)
#' s_summary(x, na.rm = TRUE)
#' s_summary(x, na.rm = FALSE)
#'
#' ## Different denominators.
#' x <- c(TRUE, FALSE, TRUE, TRUE)
#' s_summary(x, denom = "N_row", .N_row = 10L)
#' s_summary(x, denom = "N_col", .N_col = 20L)
#'
#' @export
s_summary.logical <- function(x,
                              na.rm = TRUE, # nolint
                              denom = c("n", "N_row", "N_col"),
                              .N_row, # nolint
                              .N_col, # nolint
                              ...) {
  denom <- match.arg(denom)
  if (na.rm) x <- x[!is.na(x)]
  y <- list()
  y$n <- length(x)
  count <- sum(x, na.rm = TRUE)
  dn <- switch(denom,
    n = length(x),
    N_row = .N_row,
    N_col = .N_col
  )
  y$count <- count
  y$count_fraction <- c(count, ifelse(dn > 0, count / dn, NA))
  y$n_blq <- 0L
  y
}

#' @describeIn summarize_variables S3 generic Formatted Analysis function to produce
#'   an object description. It is used as `afun` in [rtables::analyze()].
#'
#' @export
a_summary <- function(x,
                      ...,
                      .N_row, # nolint
                      .N_col, # nolint
                      .var) {
  UseMethod("a_summary", x)
}

.a_summary_numeric_formats <- summary_formats()
.a_summary_numeric_labels <- summary_labels()

#' @describeIn summarize_variables Formatted Analysis function method for `numeric`.
#'
#' @export
#'
#' @examples
#' # `a_summary.numeric`
#' a_summary(rnorm(10), .N_col = 10, .N_row = 20, .var = "bla")
a_summary.numeric <- make_afun(
  s_summary.numeric,
  .formats = .a_summary_numeric_formats,
  .labels = .a_summary_numeric_labels
)

.a_summary_counts_formats <- summary_formats(type = "counts")

#' @describeIn summarize_variables Method for `factor`.
#'
#' @export
#'
#' @examples
#' # `a_summary.factor`
#' # We need to ungroup `count` and `count_fraction` first so that the rtables formatting
#' # functions can be applied correctly.
#' afun <- make_afun(
#'   getS3method("a_summary", "factor"),
#'   .ungroup_stats = c("count", "count_fraction")
#' )
#' afun(factor(c("a", "a", "b", "c", "a")), .N_row = 10, .N_col = 10)
a_summary.factor <- make_afun(
  s_summary.factor,
  .formats = .a_summary_counts_formats
)

#' @describeIn summarize_variables Formatted Analysis function method for `character`.
#'
#' @export
#'
#' @examples
#' # `a_summary.character`
#' afun <- make_afun(
#'   getS3method("a_summary", "character"),
#'   .ungroup_stats = c("count", "count_fraction")
#' )
#' afun(c("A", "B", "A", "C"), .var = "x", .N_col = 10, .N_row = 10, verbose = FALSE)
a_summary.character <- make_afun(
  s_summary.character,
  .formats = .a_summary_counts_formats
)

#' @describeIn summarize_variables Formatted Analysis function method for `logical`.
#'
#' @export
#'
#' @examples
#' # `a_summary.logical`
#' afun <- make_afun(
#'   getS3method("a_summary", "logical")
#' )
#' afun(c(TRUE, FALSE, FALSE, TRUE, TRUE), .N_row = 10, .N_col = 10)
a_summary.logical <- make_afun(
  s_summary.logical,
  .formats = .a_summary_counts_formats
)

#' Constructor Function for [summarize_vars()] and [summarize_colvars()]
#'
#' @description Constructor function which creates a combined Formatted
#' Analysis function for use in layout creating functions [summarize_vars()] and
#' [summarize_colvars()].
#'
#' @note Since [a_summary()] is generic and we want customization of the formatting arguments
#'   via [rtables::make_afun()], we need to create another temporary generic function, with
#'   corresponding customized methods. Then in order for the methods to be found,
#'   we need to wrap them in a combined `afun`. Since this is required by two layout creating
#'   functions (and possibly others in the future), we provide a constructor that does this:
#'   [create_afun_summary()].
#' @inheritParams argument_convention
#'
#' @export
#'
#' @examples
#' # `create_afun_summary()` to create combined `afun`
#'
#' afun <- create_afun_summary(
#'   .stats = NULL,
#'   .formats = c(median = "xx."),
#'   .labels = c(median = "My median"),
#'   .indent_mods = c(median = 1L)
#' )
#' ## Fabricated dataset.
#' dta_test <- data.frame(
#'   USUBJID = rep(1:6, each = 3),
#'   PARAMCD = rep("lab", 6 * 3),
#'   AVISIT  = rep(paste0("V", 1:3), 6),
#'   ARM     = rep(LETTERS[1:3], rep(6, 3)),
#'   AVAL    = c(9:1, rep(NA, 9))
#' )
#'
#' l <- basic_table() %>%
#'   split_cols_by(var = "ARM") %>%
#'   split_rows_by(var = "AVISIT") %>%
#'   analyze(vars = "AVAL", afun = afun)
#'
#' build_table(l, df = dta_test)
create_afun_summary <- function(.stats, .formats, .labels, .indent_mods) {
  function(x,
           ...,
           .N_row, # nolint
           .N_col, # nolint
           .var) {
    afun <- function(x, ...) {
      UseMethod("afun", x)
    }

    numeric_stats <- afun_selected_stats(
      .stats,
      all_stats = names(.a_summary_numeric_formats)
    )
    afun.numeric <- make_afun( # nolint
      a_summary.numeric,
      .stats = numeric_stats,
      .formats = extract_by_name(.formats, numeric_stats),
      .labels = extract_by_name(.labels, numeric_stats),
      .indent_mods = extract_by_name(.indent_mods, numeric_stats)
    )

    factor_stats <- afun_selected_stats(.stats, c("n", "count", "count_fraction"))
    ungroup_stats <- afun_selected_stats(.stats, c("count", "count_fraction"))
    afun.factor <- make_afun( # nolint
      a_summary.factor,
      .stats = factor_stats,
      .formats = extract_by_name(.formats, factor_stats),
      .labels = extract_by_name(.labels, factor_stats),
      .indent_mods = extract_by_name(.indent_mods, factor_stats),
      .ungroup_stats = ungroup_stats
    )

    afun.character <- make_afun( # nolint
      a_summary.character,
      .stats = factor_stats,
      .formats = extract_by_name(.formats, factor_stats),
      .labels = extract_by_name(.labels, factor_stats),
      .indent_mods = extract_by_name(.indent_mods, factor_stats),
      .ungroup_stats = ungroup_stats
    )

    afun.logical <- make_afun( # nolint
      a_summary.logical,
      .stats = factor_stats,
      .formats = extract_by_name(.formats, factor_stats),
      .labels = extract_by_name(.labels, factor_stats),
      .indent_mods = extract_by_name(.indent_mods, factor_stats)
    )

    afun(
      x = x,
      ...,
      .N_row = .N_row,
      .N_col = .N_col,
      .var = .var
    )
  }
}

#' @describeIn summarize_variables Analyze Function to add a descriptive analyze
#'   layer to `rtables` pipelines. The analysis is applied to a vector and
#'   return the summary, in `rcells`. The ellipsis (`...`) conveys arguments to
#'   [s_summary()], for instance `na.rm = FALSE` if missing data should be
#'   accounted for. When factor variables contains `NA`, it is expected that `NA`
#'   have been conveyed to `na_level` appropriately beforehand with
#'   [df_explicit_na()].
#' @inheritParams rtables::analyze
#' @param ... arguments passed to `s_summary()`.
#'
#' @template formatting_arguments
#' @export
#'
#' @examples
#' ## Fabricated dataset.
#' dta_test <- data.frame(
#'   USUBJID = rep(1:6, each = 3),
#'   PARAMCD = rep("lab", 6 * 3),
#'   AVISIT  = rep(paste0("V", 1:3), 6),
#'   ARM     = rep(LETTERS[1:3], rep(6, 3)),
#'   AVAL    = c(9:1, rep(NA, 9))
#' )
#'
#' # `summarize_vars()` in `rtables` pipelines
#' ## Default output within a `rtables` pipeline.
#' l <- basic_table() %>%
#'   split_cols_by(var = "ARM") %>%
#'   split_rows_by(var = "AVISIT") %>%
#'   summarize_vars(vars = "AVAL")
#'
#' build_table(l, df = dta_test)
#'
#' ## Select and format statistics output.
#' l <- basic_table() %>%
#'   split_cols_by(var = "ARM") %>%
#'   split_rows_by(var = "AVISIT") %>%
#'   summarize_vars(
#'     vars = "AVAL",
#'     .stats = c("n", "mean_sd", "quantiles"),
#'     .formats = c("mean_sd" = "xx.x, xx.x"),
#'     .labels = c(n = "n", mean_sd = "Mean, SD", quantiles = c("Q1 - Q3"))
#'   )
#'
#' results <- build_table(l, df = dta_test)
#' as_html(results)
#'
#' ## Use arguments interpreted by `s_summary`.
#' l <- basic_table() %>%
#'   split_cols_by(var = "ARM") %>%
#'   split_rows_by(var = "AVISIT") %>%
#'   summarize_vars(vars = "AVAL", na.rm = FALSE)
#'
#' results <- build_table(l, df = dta_test)
#'
#' ## Handle `NA` levels first when summarizing factors.
#' dta_test$AVISIT <- NA_character_
#' dta_test <- df_explicit_na(dta_test)
#' l <- basic_table() %>%
#'   split_cols_by(var = "ARM") %>%
#'   summarize_vars(vars = "AVISIT", na.rm = FALSE)
#'
#' results <- build_table(l, df = dta_test)
#' \dontrun{
#' Viewer(results)
#' }
summarize_vars <- function(lyt,
                           vars,
                           var_labels = vars,
                           nested = TRUE,
                           ...,
                           show_labels = "default",
                           table_names = vars,
                           .stats = c("n", "mean_sd", "median", "range", "count_fraction"),
                           .formats = NULL,
                           .labels = NULL,
                           .indent_mods = NULL) {
  afun <- create_afun_summary(.stats, .formats, .labels, .indent_mods)

  analyze(
    lyt = lyt,
    vars = vars,
    var_labels = var_labels,
    afun = afun,
    nested = nested,
    extra_args = list(...),
    inclNAs = TRUE,
    show_labels = show_labels,
    table_names = table_names
  )
}

#' Subgroup Treatment Effect Pattern (STEP) Fit for Survival Outcome
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This fits the Subgroup Treatment Effect Pattern models for a survival outcome. The treatment arm
#' variable must have exactly 2 levels, where the first one is taken as reference and the estimated
#' hazard ratios are for the comparison of the second level vs. the first one.
#'
#' The model which is fit is:
#'
#' `Surv(time, event) ~ arm * poly(biomarker, degree) + covariates + strata(strata)`
#'
#' where `degree` is specified by `control_step()`.
#' Note that for the default degree 0 the `biomarker` variable is not included in the model.
#'
#' @inheritParams argument_convention
#' @param variables (named `list` of `character`)\cr list of analysis variables: needs `time`, `event`,
#'   `arm`, `biomarker`, and optional `covariates` and `strata`.
#' @param control (named `list`)\cr combined control list from [control_step()] and [control_coxph()].
#' @return a matrix of class `step`. The first part of the columns describe the subgroup intervals used
#'   for the biomarker variable, including where the center of the intervals are and their bounds. The
#'   second part of the columns contain the estimates for the treatment arm comparison.
#' @seealso [control_step()] and [control_coxph()] for the available customization options.
#' @export
#'
#' @examples
#' # Testing dataset with just two treatment arms.
#' library(dplyr)
#'
#' adtte_f <- tern_ex_adtte %>%
#'   filter(
#'     PARAMCD == "OS",
#'     ARM %in% c("B: Placebo", "A: Drug X")
#'   ) %>%
#'   mutate(
#'     # Reorder levels of ARM to display reference arm before treatment arm.
#'     ARM = droplevels(forcats::fct_relevel(ARM, "B: Placebo")),
#'     is_event = CNSR == 0
#'   )
#' labels <- c("ARM" = "Treatment Arm", "is_event" = "Event Flag")
#' formatters::var_labels(adtte_f)[names(labels)] <- labels
#'
#' variables <- list(
#'   arm = "ARM",
#'   biomarker = "BMRKR1",
#'   covariates = c("AGE", "BMRKR2"),
#'   event = "is_event",
#'   time = "AVAL"
#' )
#'
#' # Fit default STEP models: Here a constant treatment effect is estimated in each subgroup.
#' step_matrix <- fit_survival_step(
#'   variables = variables,
#'   data = adtte_f
#' )
#' dim(step_matrix)
#' head(step_matrix)
#'
#' # Specify different polynomial degree for the biomarker interaction to use more flexible local
#' # models. Or specify different Cox regression options.
#' step_matrix2 <- fit_survival_step(
#'   variables = variables,
#'   data = adtte_f,
#'   control = c(control_coxph(conf_level = 0.9), control_step(degree = 2))
#' )
#'
#' # Use a global model with cubic interaction and only 5 points.
#' step_matrix3 <- fit_survival_step(
#'   variables = variables,
#'   data = adtte_f,
#'   control = c(control_coxph(), control_step(bandwidth = NULL, degree = 3, num_points = 5L))
#' )
fit_survival_step <- function(variables,
                              data,
                              control = c(control_step(), control_coxph())) {
  checkmate::assert_list(control)
  assert_df_with_variables(data, variables)
  data <- data[!is.na(data[[variables$biomarker]]), ]
  window_sel <- h_step_window(x = data[[variables$biomarker]], control = control)
  interval_center <- window_sel$interval[, "Interval Center"]
  form <- h_step_survival_formula(variables = variables, control = control)
  estimates <- if (is.null(control$bandwidth)) {
    h_step_survival_est(
      formula = form,
      data = data,
      variables = variables,
      x = interval_center,
      control = control
    )
  } else {
    tmp <- mapply(
      FUN = h_step_survival_est,
      x = interval_center,
      subset = as.list(as.data.frame(window_sel$sel)),
      MoreArgs = list(
        formula = form,
        data = data,
        variables = variables,
        control = control
      )
    )
    # Maybe we find a more elegant solution than this.
    rownames(tmp) <- c("n", "events", "loghr", "se", "ci_lower", "ci_upper")
    t(tmp)
  }
  result <- cbind(window_sel$interval, estimates)
  structure(
    result,
    class = c("step", "matrix"),
    variables = variables,
    control = control
  )
}

#' Tabulate Biomarker Effects on Survival by Subgroup
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Tabulate the estimated effects of multiple continuous biomarker variables
#' across population subgroups.
#'
#' @details These functions create a layout starting from a data frame which contains
#'   the required statistics. The tables are then typically used as input for forest plots.
#'
#' @inheritParams argument_convention
#' @inheritParams fit_coxreg_multivar
#' @inheritParams survival_duration_subgroups
#' @name survival_biomarkers_subgroups
#'
#' @examples
#' library(dplyr)
#'
#' adtte <- tern_ex_adtte
#'
#' # Save variable labels before data processing steps.
#' adtte_labels <- formatters::var_labels(adtte)
#'
#' adtte_f <- adtte %>%
#'   filter(PARAMCD == "OS") %>%
#'   mutate(
#'     AVALU = as.character(AVALU),
#'     is_event = CNSR == 0
#'   )
#' labels <- c("AVALU" = adtte_labels[["AVALU"]], "is_event" = "Event Flag")
#' formatters::var_labels(adtte_f)[names(labels)] <- labels
#'
#' df <- extract_survival_biomarkers(
#'   variables = list(
#'     tte = "AVAL",
#'     is_event = "is_event",
#'     biomarkers = c("BMRKR1", "AGE"),
#'     strata = "STRATA1",
#'     covariates = "SEX",
#'     subgroups = "BMRKR2"
#'   ),
#'   data = adtte_f
#' )
#' df
NULL

#' Prepares Survival Data Estimates for Multiple Biomarkers in a Single Data Frame
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Prepares estimates for number of events, patients and median survival
#' times, as well as hazard ratio estimates, confidence intervals and p-values, for multiple biomarkers across
#' population subgroups in a single data frame.
#' `variables` corresponds to the names of variables found in `data`, passed as a named list and requires elements
#' `tte`, `is_event`, `biomarkers` (vector of continuous biomarker variables) and optionally `subgroups` and `strat`.
#' `groups_lists` optionally specifies groupings for `subgroups` variables.
#'
#' @inheritParams argument_convention
#' @inheritParams fit_coxreg_multivar
#' @inheritParams survival_duration_subgroups
#'
#' @seealso [h_coxreg_mult_cont_df()] which is used internally, [tabulate_survival_biomarkers()].
#' @export
#' @examples
#' # Typical analysis of two continuous biomarkers `BMRKR1` and `AGE`,
#' # in multiple regression models containing one covariate `RACE`,
#' # as well as one stratification variable `STRATA1`. The subgroups
#' # are defined by the levels of `BMRKR2`.
#'
#' library(dplyr)
#'
#' adtte <- tern_ex_adtte
#' adtte_labels <- formatters::var_labels(adtte)
#'
#' adtte_f <- adtte %>%
#'   filter(PARAMCD == "OS") %>%
#'   mutate(
#'     AVALU = as.character(AVALU),
#'     is_event = CNSR == 0
#'   )
#' labels <- c("AVALU" = adtte_labels[["AVALU"]], "is_event" = "Event Flag")
#' formatters::var_labels(adtte_f)[names(labels)] <- labels
#'
#' df <- extract_survival_biomarkers(
#'   variables = list(
#'     tte = "AVAL",
#'     is_event = "is_event",
#'     biomarkers = c("BMRKR1", "AGE"),
#'     strata = "STRATA1",
#'     covariates = "SEX",
#'     subgroups = "BMRKR2"
#'   ),
#'   data = adtte_f
#' )
#' df
#'
#' # Here we group the levels of `BMRKR2` manually.
#' df_grouped <- extract_survival_biomarkers(
#'   variables = list(
#'     tte = "AVAL",
#'     is_event = "is_event",
#'     biomarkers = c("BMRKR1", "AGE"),
#'     strata = "STRATA1",
#'     covariates = "SEX",
#'     subgroups = "BMRKR2"
#'   ),
#'   data = adtte_f,
#'   groups_lists = list(
#'     BMRKR2 = list(
#'       "low" = "LOW",
#'       "low/medium" = c("LOW", "MEDIUM"),
#'       "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
#'     )
#'   )
#' )
#' df_grouped
extract_survival_biomarkers <- function(variables,
                                        data,
                                        groups_lists = list(),
                                        control = control_coxreg(),
                                        label_all = "All Patients") {
  checkmate::assert_list(variables)
  checkmate::assert_character(variables$subgroups, null.ok = TRUE)
  checkmate::assert_string(label_all)

  # Start with all patients.
  result_all <- h_coxreg_mult_cont_df(
    variables = variables,
    data = data,
    control = control
  )
  result_all$subgroup <- label_all
  result_all$var <- "ALL"
  result_all$var_label <- label_all
  result_all$row_type <- "content"
  if (is.null(variables$subgroups)) {
    # Only return result for all patients.
    result_all
  } else {
    # Add subgroups results.
    l_data <- h_split_by_subgroups(
      data,
      variables$subgroups,
      groups_lists = groups_lists
    )
    l_result <- lapply(l_data, function(grp) {
      result <- h_coxreg_mult_cont_df(
        variables = variables,
        data = grp$df,
        control = control
      )
      result_labels <- grp$df_labels[rep(1, times = nrow(result)), ]
      cbind(result, result_labels)
    })
    result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE))
    result_subgroups$row_type <- "analysis"
    rbind(
      result_all,
      result_subgroups
    )
  }
}

#' @describeIn survival_biomarkers_subgroups table creating function.
#'
#' @param df (`data.frame`)\cr containing all analysis variables, as returned by
#'   [extract_survival_biomarkers()].
#' @param vars (`character`)\cr the names of statistics to be reported among:
#'   - `n_tot_events`: total number of events per group.
#'   - `n_tot`: total number of observations per group.
#'   - `median`: median survival time.
#'   - `hr`: hazard ratio.
#'   - `ci`: confidence interval of hazard ratio.
#'   - `pval`: p-value of the effect.
#'   Note, one of the statistics `n_tot` and `n_tot_events`, as well as both `hr` and `ci` are required.
#' @seealso [h_tab_surv_one_biomarker()] which is used internally, [extract_survival_biomarkers()].
#' @note In contrast to [tabulate_survival_subgroups()] this tabulation function does
#'   not start from an input layout `lyt`. This is because internally the table is
#'   created by combining multiple subtables.
#' @export
#'
#' @examples
#' ## Table with default columns.
#' tabulate_survival_biomarkers(df)
#'
#' ## Table with a manually chosen set of columns: leave out "pval", reorder.
#' tab <- tabulate_survival_biomarkers(
#'   df = df,
#'   vars = c("n_tot_events", "ci", "n_tot", "median", "hr"),
#'   time_unit = as.character(adtte_f$AVALU[1])
#' )
#'
#' ## Finally produce the forest plot.
#' \dontrun{
#' g_forest(tab, xlim = c(0.8, 1.2))
#' }
tabulate_survival_biomarkers <- function(df,
                                         vars = c("n_tot", "n_tot_events", "median", "hr", "ci", "pval"),
                                         time_unit = NULL) {
  checkmate::assert_data_frame(df)
  checkmate::assert_character(df$biomarker)
  checkmate::assert_character(df$biomarker_label)
  checkmate::assert_subset(vars, c("n_tot", "n_tot_events", "median", "hr", "ci", "pval"))

  df_subs <- split(df, f = df$biomarker)
  tabs <- lapply(df_subs, FUN = function(df_sub) {
    tab_sub <- h_tab_surv_one_biomarker(
      df = df_sub,
      vars = vars,
      time_unit = time_unit
    )
    # Insert label row as first row in table.
    label_at_path(tab_sub, path = row_paths(tab_sub)[[1]][1]) <- df_sub$biomarker_label[1]
    tab_sub
  })
  result <- do.call(rbind, tabs)

  n_tot_ids <- grep("^n_tot", vars)
  hr_id <- match("hr", vars)
  ci_id <- match("ci", vars)
  structure(
    result,
    forest_header = paste0(c("Higher", "Lower"), "\nBetter"),
    col_x = hr_id,
    col_ci = ci_id,
    col_symbol_size = n_tot_ids[1]
  )
}

#' Summary for Poisson Negative Binomial.
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Summarize results of a Poisson Negative Binomial Regression.
#' This can be used to analyze count and/or frequency data using a linear model.
#'
#' @name summarize_glm_count
#'
NULL

#' Helper Functions for Poisson Models.
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' Helper functions that can be used to return the results of various Poisson models.
#'
#' @seealso [summarize_glm_count]
#'
#' @name h_glm_count
#'
NULL

#' @describeIn h_glm_count Helper function to return results of a poisson model.
#'
#' @inheritParams argument_convention
#' @param .df_row (`data.frame`)\cr data set that includes all the variables that are called
#'   in `.var` and `variables`.
#' @param variables (named `list` of `strings`)\cr list of additional analysis variables, with
#'   expected elements:
#'   - `arm` (`string`)\cr group variable, for which the covariate adjusted means of multiple
#'     groups will be summarized. Specifically, the first level of `arm` variable is taken as the
#'     reference group.
#'   - `covariates` (`character`)\cr a vector that can contain single variable names (such as
#'     `"X1"`), and/or interaction terms indicated by `"X1 * X2"`.
#'   - `offset` (`numeric`)\cr a numeric vector or scalar adding an offset.
#' @param `weights`(`character`)\cr a character vector specifying weights used
#'  in averaging predictions. Number of weights must equal the number of levels included in the covariates.
#'  Weights option passed to emmeans function (hyperlink) (link to emmeans documentation)
#'
#' @examples
#' # Internal function - h_glm_poisson
#' \dontrun{
#' h_glm_poisson(
#'   .var = "AVAL",
#'   .df_row = anl,
#'   variables = list(arm = "ARM", offset = "lgTMATRSK", covariates = NULL)
#' )
#' }
#'
#' @keywords internal
h_glm_poisson <- function(.var,
                          .df_row,
                          variables,
                          weights) {
  arm <- variables$arm
  covariates <- variables$covariates
  offset <- .df_row[[variables$offset]]

  formula <- stats::as.formula(paste0(
    .var, " ~ ",
    " + ",
    paste(covariates, collapse = " + "),
    " + ",
    arm
  ))

  glm_fit <- stats::glm(
    formula = formula,
    offset = offset,
    data = .df_row,
    family = stats::poisson(link = "log")
  )

  emmeans_fit <- emmeans::emmeans(
    glm_fit,
    specs = arm,
    data = .df_row,
    type = "response",
    offset = 0,
    weights = weights
  )

  list(
    glm_fit = glm_fit,
    emmeans_fit = emmeans_fit
  )
}

#' @describeIn h_glm_count Helper function to return results of a quasipoisson model.
#' @inheritParams argument_convention
#' @inheritParams summarize_glm_count
#'
#' @examples
#'
#' # Internal function - h_glm_quasipoisson
#' \dontrun{
#' h_glm_quasipoisson(
#'   .var = "AVAL",
#'   .df_row = anl,
#'   variables = list(arm = "ARM", offset = "lgTMATRSK", covariates = c("REGION1"))
#' )
#' }
#'
#' @keywords internal
h_glm_quasipoisson <- function(.var,
                               .df_row,
                               variables,
                               weights) {
  arm <- variables$arm
  covariates <- variables$covariates
  offset <- .df_row[[variables$offset]]

  formula <- stats::as.formula(paste0(
    .var, " ~ ",
    " + ",
    paste(covariates, collapse = " + "),
    " + ",
    arm
  ))

  glm_fit <- stats::glm(
    formula = formula,
    offset = offset,
    data = .df_row,
    family = stats::quasipoisson(link = "log")
  )

  emmeans_fit <- emmeans::emmeans(
    glm_fit,
    specs = arm,
    data = .df_row,
    type = "response",
    offset = 0,
    weights = weights
  )

  list(
    glm_fit = glm_fit,
    emmeans_fit = emmeans_fit
  )
}

#' @describeIn h_glm_count Helper function to return the results of the
#'   selected model (poisson, quasipoisson, negative binomial).
#'
#' @inheritParams argument_convention
#' @param .df_row (`data.frame`)\cr data set that includes all the variables that are called
#'   in `.var` and `variables`.
#' @param variables (named `list` of `strings`)\cr list of additional analysis variables, with
#'   expected elements:
#'   - `arm` (`string`)\cr group variable, for which the covariate adjusted means of multiple
#'     groups will be summarized. Specifically, the first level of `arm` variable is taken as the
#'     reference group.
#'   - `covariates` (`character`)\cr a vector that can contain single variable names (such as
#'     `"X1"`), and/or interaction terms indicated by `"X1 * X2"`.
#'   - `offset` (`numeric`)\cr a numeric vector or scalar adding an offset.
#' @param `weights`(`character`)\cr character vector specifying weights used in averaging predictions.
#' @param `distribution`(`character`)\cr a character value specifying the distribution
#'   used in the regression (poisson, quasipoisson).
#'
#' @examples
#' # Internal function - h_glm_count
#' \dontrun{
#' h_glm_count(
#'   .var = "AVAL",
#'   .df_row = anl,
#'   variables = list(arm = "ARMCD", offset = "lgTMATRSK", covariates = NULL),
#'   distribution = "poisson"
#' )
#' }
#'
#' @keywords internal
h_glm_count <- function(.var,
                        .df_row,
                        variables,
                        distribution,
                        weights) {
  if (distribution == "negbin") {
    stop("negative binomial distribution is not currently available.")
  }
  switch(distribution,
    poisson = h_glm_poisson(.var, .df_row, variables, weights),
    quasipoisson = h_glm_quasipoisson(.var, .df_row, variables, weights),
    negbin = list() # h_glm_negbin(.var, .df_row, variables, weights) # nolint
  )
}


#' @describeIn h_glm_count Helper function to return the estimated means.
#'
#' @inheritParams argument_convention
#' @param .df_row (`data.frame`)\cr data set that includes all the variables that are called
#'   in `.var` and `variables`.
#' @param conf_level (`numeric`)\cr value used to derive the confidence interval for the rate.
#' @param obj (`glm.fit`)\cr fitted model object used to derive the mean rate estimates in each treatment arm.
#' @param `arm` (`string`)\cr group variable, for which the covariate adjusted means of multiple
#'   groups will be summarized. Specifically, the first level of `arm` variable is taken as the
#'   reference group.
#'
#' @examples
#' # Internal function - h_ppmeans
#' \dontrun{
#' fits <- h_glm_count(
#'   .var = "AVAL",
#'   .df_row = anl,
#'   variables = list(arm = "ARMCD", offset = "lgTMATRSK", covariates = c("REGION1")),
#'   distribution = "quasipoisson"
#' )
#'
#' h_ppmeans(
#'   obj = fits$glm_fit,
#'   .df_row = anl,
#'   arm = "ARM",
#'   conf_level = 0.95
#' )
#' }
#'
#' @keywords internal
h_ppmeans <- function(obj, .df_row, arm, conf_level) {
  alpha <- 1 - conf_level
  p <- 1 - alpha / 2

  arm_levels <- levels(.df_row[[arm]])

  out <- lapply(arm_levels, function(lev) {
    temp <- .df_row
    temp[[arm]] <- factor(lev, levels = arm_levels)

    mf <- stats::model.frame(obj$formula, data = temp)
    X <- stats::model.matrix(obj$formula, data = mf) # nolint

    rate <- stats::predict(obj, newdata = mf, type = "response")
    rate_hat <- mean(rate)

    zz <- colMeans(rate * X)
    se <- sqrt(as.numeric(t(zz) %*% stats::vcov(obj) %*% zz))
    rate_lwr <- rate_hat * exp(-stats::qnorm(p) * se / rate_hat)
    rate_upr <- rate_hat * exp(stats::qnorm(p) * se / rate_hat)

    c(rate_hat, rate_lwr, rate_upr)
  })

  names(out) <- arm_levels
  out <- do.call(rbind, out)
  if ("negbin" %in% class(obj)) {
    colnames(out) <- c("response", "asymp.LCL", "asymp.UCL")
  } else {
    colnames(out) <- c("rate", "asymp.LCL", "asymp.UCL")
  }
  out <- as.data.frame(out)
  out[[arm]] <- rownames(out)
  out
}

#' @describeIn summarize_glm_count Statistics function that produces a named list of results
#'   of the investigated poisson model.
#'
#' @inheritParams argument_convention
#' @inheritParams h_glm_count
#' @return A named list of 5 statistics:
#' \describe{
#'   \item{n}{count of complete sample size for the group.}
#'   \item{rate}{estimated event rate per follow-up time.}
#'   \item{rate_ci}{confidence level for estimated rate per follow-up time.}
#'   \item{rate_ratio}{ratio of event rates in each treatment arm to the reference arm.}
#'   \item{rate_ratio_ci}{confidence level for the rate ratio.}
#'   \item{pval}{p-value.}
#' }
#'
#' @examples
#' # Internal function - s_change_from_baseline
#' \dontrun{
#' s_glm_count(
#'   df = anl %>%
#'     filter(ARMCD == "ARM B"),
#'   .df_row = anl,
#'   .var = "AVAL",
#'   .in_ref_col = TRUE,
#'   variables = list(arm = "ARMCD", offset = "lgTMATRSK", covariates = c("REGION1")),
#'   conf_level = 0.95,
#'   distribution = "quasipoisson",
#'   rate_mean_method = "ppmeans"
#' )
#' }
#'
#' @keywords internal
s_glm_count <- function(df,
                        .var,
                        .df_row,
                        variables,
                        .ref_group,
                        .in_ref_col,
                        distribution,
                        conf_level,
                        rate_mean_method,
                        weights,
                        scale = 1) {
  arm <- variables$arm

  y <- df[[.var]]
  smry_level <- as.character(unique(df[[arm]]))

  # ensure there is only 1 value
  checkmate::assert_scalar(smry_level)

  results <- h_glm_count(
    .var = .var,
    .df_row = .df_row,
    variables = variables,
    distribution = distribution,
    weights
  )

  if (rate_mean_method == "emmeans") {
    emmeans_smry <- summary(results$emmeans_fit, level = conf_level)
  } else if (rate_mean_method == "ppmeans") {
    emmeans_smry <- h_ppmeans(results$glm_fit, .df_row, arm, conf_level)
  }

  emmeans_smry_level <- emmeans_smry[emmeans_smry[[arm]] == smry_level, ]

  if (.in_ref_col) {
    list(
      n = length(y[!is.na(y)]),
      rate = formatters::with_label(
        ifelse(distribution == "negbin", emmeans_smry_level$response * scale, emmeans_smry_level$rate),
        "Adjusted Rate"
      ),
      rate_ci = formatters::with_label(
        c(emmeans_smry_level$asymp.LCL * scale, emmeans_smry_level$asymp.UCL * scale),
        f_conf_level(conf_level)
      ),
      rate_ratio = formatters::with_label(character(), "Adjusted Rate Ratio"),
      rate_ratio_ci = formatters::with_label(character(), f_conf_level(conf_level)),
      pval = formatters::with_label(character(), "p-value")
    )
  } else {
    emmeans_contrasts <- emmeans::contrast(
      results$emmeans_fit,
      method = "trt.vs.ctrl",
      ref = grep(
        as.character(unique(.ref_group[[arm]])),
        as.data.frame(results$emmeans_fit)[[arm]]
      )
    )

    contrasts_smry <- summary(
      emmeans_contrasts,
      infer = TRUE,
      adjust = "none"
    )

    smry_contrasts_level <- contrasts_smry[grepl(smry_level, contrasts_smry$contrast), ]

    list(
      n = length(y[!is.na(y)]),
      rate = formatters::with_label(
        ifelse(distribution == "negbin", emmeans_smry_level$response * scale, emmeans_smry_level$rate),
        "Adjusted Rate"
      ),
      rate_ci = formatters::with_label(
        c(emmeans_smry_level$asymp.LCL * scale, emmeans_smry_level$asymp.UCL * scale),
        f_conf_level(conf_level)
      ),
      rate_ratio = formatters::with_label(smry_contrasts_level$ratio, "Adjusted Rate Ratio"),
      rate_ratio_ci = formatters::with_label(
        c(smry_contrasts_level$asymp.LCL, smry_contrasts_level$asymp.UCL),
        f_conf_level(conf_level)
      ),
      pval = formatters::with_label(smry_contrasts_level$p.value, "p-value")
    )
  }
}

#' @describeIn summarize_glm_count Formatted Analysis function which can be further customized by calling
#'   [rtables::make_afun()] on it. It is used as `afun` in [rtables::analyze()].
#'
#' @examples
#'
#' # Internal function - s_change_from_baseline
#' \dontrun{
#' a_glm_count(
#'   df = anl %>%
#'     filter(ARMCD == "ARM A"),
#'   .var = "AVAL",
#'   .df_row = anl,
#'   variables = list(arm = "ARMCD", offset = "lgTMATRSK", covariates = c("REGION1")),
#'   .ref_group = "ARM B", .in_ref_col = TRUE,
#'   conf_level = 0.95,
#'   distribution = "poisson",
#'   rate_mean_method = "ppmeans"
#' )
#' }
#'
#' @keywords internal
a_glm_count <- make_afun(
  s_glm_count,
  .indent_mods = c(
    "n" = 0L,
    "rate" = 0L,
    "rate_ci" = 1L,
    "rate_ratio" = 0L,
    "rate_ratio_ci" = 1L,
    "pval" = 1L
  ),
  .formats = c(
    "n" = "xx",
    "rate" = "xx.xxxx",
    "rate_ci" = "(xx.xxxx, xx.xxxx)",
    "rate_ratio" = "xx.xxxx",
    "rate_ratio_ci" = "(xx.xxxx, xx.xxxx)",
    "pval" = "x.xxxx | (<0.0001)"
  ),
  .null_ref_cells = FALSE
)

#' @describeIn summarize_glm_count Layout creating function which can be be used for creating
#'   summary tables for analysis of count data using generalized linear models (poisson, quasipoisson).
#' @inheritParams argument_convention
#' @export
#' @examples
#' library(dplyr)
#' anl <- tern_ex_adtte %>% filter(PARAMCD == "TNE")
#' anl$AVAL_f <- as.factor(anl$AVAL)
#'
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM", ref_group = "B: Placebo") %>%
#'   add_colcounts() %>%
#'   summarize_vars(
#'     "AVAL_f",
#'     var_labels = "Number of exacerbations per patient",
#'     .stats = c("count_fraction"),
#'     .formats = c("count_fraction" = "xx (xx.xx%)"),
#'     .label = c("Number of exacerbations per patient")
#'   ) %>%
#'   summarize_glm_count(
#'     vars = "AVAL",
#'     variables = list(arm = "ARM", offset = "lgTMATRSK", covariates = NULL),
#'     conf_level = 0.95,
#'     distribution = "poisson",
#'     rate_mean_method = "emmeans",
#'     var_labels = "Unadjusted exacerbation rate (per year)",
#'     table_names = "unadj",
#'     .stats = c("rate"),
#'     .labels = c(rate = "Rate")
#'   ) %>%
#'   summarize_glm_count(
#'     vars = "AVAL",
#'     variables = list(arm = "ARM", offset = "lgTMATRSK", covariates = c("REGION1")),
#'     conf_level = 0.95,
#'     distribution = "quasipoisson",
#'     rate_mean_method = "ppmeans",
#'     var_labels = "Adjusted (QP) exacerbation rate (per year)",
#'     table_names = "adj",
#'     .stats = c("rate", "rate_ci", "rate_ratio", "rate_ratio_ci", "pval"),
#'     .labels = c(
#'       rate = "Rate", rate_ci = "Rate CI", rate_ratio = "Rate Ratio",
#'       rate_ratio_ci = "Rate Ratio CI", pval = "p value"
#'     )
#'   )
#' build_table(lyt = lyt, df = anl)
summarize_glm_count <- function(lyt,
                                vars,
                                var_labels,
                                ...,
                                show_labels = "visible",
                                table_names = vars,
                                .stats = NULL,
                                .formats = NULL,
                                .labels = NULL,
                                .indent_mods = NULL) {
  afun <- make_afun(
    a_glm_count,
    .stats = .stats,
    .formats = .formats,
    .labels = .labels,
    .indent_mods = .indent_mods
  )

  analyze(
    lyt,
    vars,
    var_labels = var_labels,
    show_labels = show_labels,
    table_names = table_names,
    afun = afun,
    extra_args = list(...)
  )
}

#' Tabulate Biomarker Effects on Binary Response by Subgroup
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Tabulate the estimated effects of multiple continuous biomarker variables
#' on a binary response endpoint across population subgroups.
#'
#' @details These functions create a layout starting from a data frame which contains
#'   the required statistics. The tables are then typically used as input for forest plots.
#'
#' @param df (`data.frame`)\cr containing all analysis variables, as returned by
#'   [extract_rsp_biomarkers()].
#' @param vars (`character`)\cr the name of statistics to be reported among
#'  `n_tot` (total number of patients per group),
#'  `n_rsp` (total number of responses per group),
#'  `prop` (total response proportion per group),
#'  `or` (odds ratio),
#'  `ci` (confidence interval of odds ratio) and
#'  `pval` (p value of the effect).
#'  Note, the statistics `n_tot`, `or` and `ci` are required.
#'
#' @seealso [h_tab_rsp_one_biomarker()] which is used internally, [extract_rsp_biomarkers()].
#' @note In contrast to [tabulate_rsp_subgroups()] this tabulation function does
#'   not start from an input layout `lyt`. This is because internally the table is
#'   created by combining multiple subtables.
#' @name response_biomarkers_subgroups
#' @export
#'
#' @examples
#' library(dplyr)
#' library(forcats)
#'
#' adrs <- tern_ex_adrs
#' adrs_labels <- formatters::var_labels(adrs)
#'
#' adrs_f <- adrs %>%
#'   filter(PARAMCD == "BESRSPI") %>%
#'   mutate(rsp = AVALC == "CR")
#' formatters::var_labels(adrs_f) <- c(adrs_labels, "Response")
#' \dontrun{
#' ## Table with default columns.
#' # df <- <need_data_input_to_work>
#' tabulate_rsp_biomarkers(df)
#'
#' ## Table with a manually chosen set of columns: leave out "pval", reorder.
#' tab <- tabulate_rsp_biomarkers(
#'   df = df,
#'   vars = c("n_rsp", "ci", "n_tot", "prop", "or")
#' )
#'
#' ## Finally produce the forest plot.
#' g_forest(tab, xlim = c(0.7, 1.4))
#' }
tabulate_rsp_biomarkers <- function(df,
                                    vars = c("n_tot", "n_rsp", "prop", "or", "ci", "pval")) {
  checkmate::assert_data_frame(df)
  checkmate::assert_character(df$biomarker)
  checkmate::assert_character(df$biomarker_label)
  checkmate::assert_subset(vars, c("n_tot", "n_rsp", "prop", "or", "ci", "pval"))

  df_subs <- split(df, f = df$biomarker)
  tabs <- lapply(df_subs, FUN = function(df_sub) {
    tab_sub <- h_tab_rsp_one_biomarker(
      df = df_sub,
      vars = vars
    )
    # Insert label row as first row in table.
    label_at_path(tab_sub, path = row_paths(tab_sub)[[1]][1]) <- df_sub$biomarker_label[1]
    tab_sub
  })
  result <- do.call(rbind, tabs)

  n_id <- grep("n_tot", vars)
  or_id <- match("or", vars)
  ci_id <- match("ci", vars)
  structure(
    result,
    forest_header = paste0(c("Lower", "Higher"), "\nBetter"),
    col_x = or_id,
    col_ci = ci_id,
    col_symbol_size = n_id
  )
}

#' Prepares Response Data Estimates for Multiple Biomarkers in a Single Data Frame
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Prepares estimates for number of responses, patients and overall response rate,
#' as well as odds ratio estimates, confidence intervals and p-values,
#' for multiple biomarkers across population subgroups in a single data frame.
#' `variables` corresponds to the names of variables found in `data`, passed as a
#' named list and requires elements `rsp` and `biomarkers` (vector of continuous
#' biomarker variables) and optionally `covariates`, `subgroups` and `strat`.
#' `groups_lists` optionally specifies groupings for `subgroups` variables.
#'
#' @inheritParams argument_convention
#' @inheritParams response_subgroups
#' @param control (named `list`)\cr controls for the response definition and the
#'   confidence level produced by [control_logistic()].
#' @seealso [h_logistic_mult_cont_df()] which is used internally.
#' @note You can also specify a continuous variable in `rsp` and then use the
#'   `response_definition` control to convert that internally to a logical
#'   variable reflecting binary response.
#' @export
#'
#' @examples
#' library(dplyr)
#' library(forcats)
#'
#' adrs <- tern_ex_adrs
#' adrs_labels <- formatters::var_labels(adrs)
#'
#' adrs_f <- adrs %>%
#'   filter(PARAMCD == "BESRSPI") %>%
#'   mutate(rsp = AVALC == "CR")
#'
#' # Typical analysis of two continuous biomarkers `BMRKR1` and `AGE`,
#' # in logistic regression models with one covariate `RACE`. The subgroups
#' # are defined by the levels of `BMRKR2`.
#' df <- extract_rsp_biomarkers(
#'   variables = list(
#'     rsp = "rsp",
#'     biomarkers = c("BMRKR1", "AGE"),
#'     covariates = "SEX",
#'     subgroups = "BMRKR2"
#'   ),
#'   data = adrs_f
#' )
#' df
#'
#' # Here we group the levels of `BMRKR2` manually, and we add a stratification
#' # variable `STRATA1`. We also here use a continuous variable `EOSDY`
#' # which is then binarized internally (response is defined as this variable
#' # being larger than 500).
#' df_grouped <- extract_rsp_biomarkers(
#'   variables = list(
#'     rsp = "EOSDY",
#'     biomarkers = c("BMRKR1", "AGE"),
#'     covariates = "SEX",
#'     subgroups = "BMRKR2",
#'     strat = "STRATA1"
#'   ),
#'   data = adrs_f,
#'   groups_lists = list(
#'     BMRKR2 = list(
#'       "low" = "LOW",
#'       "low/medium" = c("LOW", "MEDIUM"),
#'       "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
#'     )
#'   ),
#'   control = control_logistic(
#'     response_definition = "I(response > 500)"
#'   )
#' )
#' df_grouped
extract_rsp_biomarkers <- function(variables,
                                   data,
                                   groups_lists = list(),
                                   control = control_logistic(),
                                   label_all = "All Patients") {
  assert_list_of_variables(variables)
  checkmate::assert_string(variables$rsp)
  checkmate::assert_character(variables$subgroups, null.ok = TRUE)
  checkmate::assert_string(label_all)

  # Start with all patients.
  result_all <- h_logistic_mult_cont_df(
    variables = variables,
    data = data,
    control = control
  )
  result_all$subgroup <- label_all
  result_all$var <- "ALL"
  result_all$var_label <- label_all
  result_all$row_type <- "content"
  if (is.null(variables$subgroups)) {
    # Only return result for all patients.
    result_all
  } else {
    # Add subgroups results.
    l_data <- h_split_by_subgroups(
      data,
      variables$subgroups,
      groups_lists = groups_lists
    )
    l_result <- lapply(l_data, function(grp) {
      result <- h_logistic_mult_cont_df(
        variables = variables,
        data = grp$df,
        control = control
      )
      result_labels <- grp$df_labels[rep(1, times = nrow(result)), ]
      cbind(result, result_labels)
    })
    result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE))
    result_subgroups$row_type <- "analysis"
    rbind(
      result_all,
      result_subgroups
    )
  }
}

#' Cox Regression Helper: Interactions
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Test and estimate the effect of a treatment in interaction with a covariate.
#' The effect is estimated as the HR of the tested treatment for a given level
#' of the covariate, in comparison to the treatment control.
#'
#' @param x (`numeric` or `factor`)\cr the values of the effect to be tested.
#' @param effect (`string`)\cr the name of the effect to be tested and estimated.
#' @param covar (`string`)\cr the name of the covariate in the model.
#' @param mod (`coxph`)\cr the Cox regression model.
#' @param label (`string`)\cr the label to be return as `term_label`
#'   (see `return`).
#' @param control (`list`)\cr a list of controls as returned by
#'   [control_coxreg()].
#' @param ... see methods.
#'
#' @name cox_regression_inter
#'
#' @examples
#' library(survival)
#'
#' set.seed(1, kind = "Mersenne-Twister")
#'
#' # Testing dataset [survival::bladder].
#' dta_bladder <- with(
#'   data = bladder[bladder$enum < 5, ],
#'   data.frame(
#'     time = stop,
#'     status = event,
#'     armcd = as.factor(rx),
#'     covar1 = as.factor(enum),
#'     covar2 = factor(
#'       sample(as.factor(enum)),
#'       levels = 1:4,
#'       labels = c("F", "F", "M", "M")
#'     )
#'   )
#' )
#' labels <- c("armcd" = "ARM", "covar1" = "A Covariate Label", "covar2" = "Sex (F/M)")
#' formatters::var_labels(dta_bladder)[names(labels)] <- labels
#' dta_bladder$age <- sample(20:60, size = nrow(dta_bladder), replace = TRUE)
#'
#' plot(
#'   survfit(Surv(time, status) ~ armcd + covar1, data = dta_bladder),
#'   lty = 2:4,
#'   xlab = "Months",
#'   col = c("blue1", "blue2", "blue3", "blue4", "red1", "red2", "red3", "red4")
#' )
#'
#' @export
h_coxreg_inter_effect <- function(x,
                                  effect,
                                  covar,
                                  mod,
                                  label,
                                  control,
                                  ...) {
  UseMethod("h_coxreg_inter_effect", x)
}


#' @describeIn cox_regression_inter Estimate the interaction with a numerical
#'   covariate
#'
#' @param at (`list`)\cr a list with items named after the covariate, every
#'   item is a vector of levels at which the interaction should be estimated.
#' @export
h_coxreg_inter_effect.numeric <- function(x, # nolint
                                          effect,
                                          covar,
                                          mod,
                                          label,
                                          control,
                                          at,
                                          ...) {
  betas <- stats::coef(mod)
  attrs <- attr(stats::terms(mod), "term.labels")
  term_indices <- grep(
    pattern = effect,
    x = attrs[!grepl("strata\\(", attrs)]
  )
  checkmate::assert_vector(term_indices, len = 2)
  betas <- betas[term_indices]
  betas_var <- diag(stats::vcov(mod))[term_indices]
  betas_cov <- stats::vcov(mod)[term_indices[1], term_indices[2]]
  xval <- if (is.null(at[[covar]])) {
    stats::median(x)
  } else {
    at[[covar]]
  }
  effect_index <- !grepl(covar, names(betas))
  coef_hat <- betas[effect_index] + xval * betas[!effect_index]
  coef_se <- sqrt(
    betas_var[effect_index] +
      xval ^ 2 * betas_var[!effect_index] + # styler: off
      2 * xval * betas_cov
  )
  q_norm <- stats::qnorm((1 + control$conf_level) / 2)
  data.frame(
    effect = "Covariate:",
    term = rep(covar, length(xval)),
    term_label = paste0("  ", xval),
    level = as.character(xval),
    n = NA,
    hr = exp(coef_hat),
    lcl = exp(coef_hat - q_norm * coef_se),
    ucl = exp(coef_hat + q_norm * coef_se),
    pval = NA,
    pval_inter = NA,
    stringsAsFactors = FALSE
  )
}

#' @describeIn cox_regression_inter Estimate the interaction with a factor
#'   covariate.
#'
#' @param data (`data.frame`)\cr the data frame on which the model was fit.
#' @export
h_coxreg_inter_effect.factor <- function(x, # nolint
                                         effect,
                                         covar,
                                         mod,
                                         label,
                                         control,
                                         data,
                                         ...) {
  y <- h_coxreg_inter_estimations(
    variable = effect, given = covar,
    lvl_var = levels(data[[effect]]),
    lvl_given = levels(data[[covar]]),
    mod = mod,
    conf_level = 0.95
  )[[1]]

  data.frame(
    effect = "Covariate:",
    term = rep(covar, nrow(y)),
    term_label = as.character(paste0("  ", levels(data[[covar]]))),
    level = as.character(levels(data[[covar]])),
    n = NA,
    hr = y[, "hr"],
    lcl = y[, "lcl"],
    ucl = y[, "ucl"],
    pval = NA,
    pval_inter = NA,
    stringsAsFactors = FALSE
  )
}

#' @describeIn cox_regression_inter a higher level function that returns
#'   the test of the interaction test and the estimated values. If
#'   no interaction, [h_coxreg_univar_extract()] is applied.
#'
#' @export
#'
#' @examples
#' mod <- coxph(Surv(time, status) ~ armcd * covar1, data = dta_bladder)
#' h_coxreg_extract_interaction(
#'   mod = mod, effect = "armcd", covar = "covar1", data = dta_bladder,
#'   control = control_coxreg()
#' )
h_coxreg_extract_interaction <- function(effect,
                                         covar,
                                         mod,
                                         data,
                                         at,
                                         control) {
  if (!any(attr(stats::terms(mod), "order") == 2)) {
    y <- h_coxreg_univar_extract(
      effect = effect, covar = covar, mod = mod, data = data, control = control
    )
    y$pval_inter <- NA
    y
  } else {
    test_statistic <- c(wald = "Wald", likelihood = "LR")[control$pval_method]

    # Test the main treatment effect.
    mod_aov <- muffled_car_anova(mod, test_statistic)
    sum_anova <- broom::tidy(mod_aov)
    pval <- sum_anova[sum_anova$term == effect, ][["p.value"]]

    # Test the interaction effect.
    pval_inter <- sum_anova[grep(":", sum_anova$term), ][["p.value"]]
    covar_test <- data.frame(
      effect = "Covariate:",
      term = covar,
      term_label = unname(labels_or_names(data[covar])),
      level = "",
      n = mod$n, hr = NA, lcl = NA, ucl = NA, pval = pval,
      pval_inter = pval_inter,
      stringsAsFactors = FALSE
    )
    # Estimate the interaction.
    y <- h_coxreg_inter_effect(
      data[[covar]],
      covar = covar,
      effect = effect,
      mod = mod,
      label = unname(labels_or_names(data[covar])),
      at = at,
      control = control,
      data = data
    )
    rbind(covar_test, y)
  }
}

#' @describeIn cox_regression_inter hazard ratio estimation in interactions.
#'
#' @inheritParams argument_convention
#' @param variable,given (`string`)\cr the name of variables in interaction. We seek the estimation
#'   of the levels of `variable` given the levels of `given`.
#' @param lvl_var,lvl_given (`character`)\cr corresponding levels has given by [levels()].
#' @param mod (`coxph`)\cr a fitted Cox regression model (see [survival::coxph()]).
#'
#' @details Given the cox regression investigating the effect of Arm (A, B, C; reference A)
#'   and Sex (F, M; reference Female) and the model being abbreviated: y ~ Arm + Sex + Arm:Sex.
#'   The cox regression estimates the coefficients along with a variance-covariance matrix for:
#'
#'   - b1 (arm b), b2 (arm c)
#'   - b3 (sex m)
#'   - b4 (arm b: sex m), b5 (arm c: sex m)
#'
#'   The estimation of the Hazard Ratio for arm C/sex M is given in reference
#'   to arm A/Sex M by exp(b2 + b3 + b5)/ exp(b3) = exp(b2 + b5).
#'   The interaction coefficient is deduced by b2 + b5 while the standard error
#'   is obtained as $sqrt(Var b2 + Var b5 + 2 * covariance (b2,b5))$.
#'
#' @return A list of matrix (one per level of variable) with rows corresponding to the combinations of
#' `variable` and `given`, with columns:
#' \describe{
#'   \item{coef_hat}{Estimation of the coefficient.}
#'   \item{coef_se}{Standard error of the estimation.}
#'   \item{hr}{Hazard ratio.}
#'   \item{lcl, ucl}{Lower/upper confidence limit of the hazard ratio.}
#' }
#'
#' @examples
#' mod <- coxph(Surv(time, status) ~ armcd * covar1, data = dta_bladder)
#' result <- h_coxreg_inter_estimations(
#'   variable = "armcd", given = "covar1",
#'   lvl_var = levels(dta_bladder$armcd),
#'   lvl_given = levels(dta_bladder$covar1),
#'   mod = mod, conf_level = .95
#' )
#' result
#'
#' @export
h_coxreg_inter_estimations <- function(variable, given,
                                       lvl_var, lvl_given,
                                       mod,
                                       conf_level = 0.95) {
  var_lvl <- paste0(variable, lvl_var[-1]) # [-1]: reference level
  giv_lvl <- paste0(given, lvl_given)
  design_mat <- expand.grid(variable = var_lvl, given = giv_lvl)
  design_mat <- design_mat[order(design_mat$variable, design_mat$given), ]
  design_mat <- within(
    data = design_mat,
    expr = {
      inter <- paste0(variable, ":", given) # nolint
      rev_inter <- paste0(given, ":", variable) # nolint
    }
  )
  split_by_variable <- design_mat$variable
  interaction_names <- paste(design_mat$variable, design_mat$given, sep = "/")

  mmat <- stats::model.matrix(mod)[1, ]
  mmat[!mmat == 0] <- 0

  design_mat <- apply(
    X = design_mat, MARGIN = 1, FUN = function(x) {
      mmat[names(mmat) %in% x[-which(names(x) == "given")]] <- 1
      mmat
    }
  )
  colnames(design_mat) <- interaction_names

  coef <- stats::coef(mod)
  vcov <- stats::vcov(mod)
  betas <- as.matrix(coef)
  coef_hat <- t(design_mat) %*% betas
  dimnames(coef_hat)[2] <- "coef"
  coef_se <- apply(
    design_mat, 2,
    function(x) {
      vcov_el <- as.logical(x)
      y <- vcov[vcov_el, vcov_el]
      y <- sum(y)
      y <- sqrt(y)
      return(y)
    }
  )
  q_norm <- stats::qnorm((1 + conf_level) / 2)
  y <- cbind(coef_hat, `se(coef)` = coef_se)
  y <- apply(y, 1, function(x) {
    x["hr"] <- exp(x["coef"])
    x["lcl"] <- exp(x["coef"] - q_norm * x["se(coef)"])
    x["ucl"] <- exp(x["coef"] + q_norm * x["se(coef)"])
    x
  })
  y <- t(y)
  y <- by(y, split_by_variable, identity)
  y <- lapply(y, as.matrix)
  attr(y, "details") <- paste0(
    "Estimations of ", variable,
    " hazard ratio given the level of ", given, " compared to ",
    variable, " level ", lvl_var[1], "."
  )
  y
}

#' Missing Data
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Substitute missing data with a string or factor level.
#'
#' @param x factor or character vector
#' @param label character string that missing data should be replaced with
#'
#' @export
#'
#' @examples
#' explicit_na(c(NA, "a", "b"))
#' is.na(explicit_na(c(NA, "a", "b")))
#'
#' explicit_na(factor(c(NA, "a", "b")))
#' is.na(explicit_na(factor(c(NA, "a", "b"))))
#'
#' explicit_na(sas_na(c("a", "")))
explicit_na <- function(x, label = "<Missing>") {
  checkmate::assert_string(label)

  if (is.factor(x)) {
    x <- forcats::fct_na_value_to_level(x, label)
    forcats::fct_drop(x, only = label)
  } else if (is.character(x)) {
    x[is.na(x)] <- label
    x
  } else {
    stop("only factors and character vectors allowed")
  }
}

#' Convert Strings to `NA`
#'
#' @description `r lifecycle::badge("stable")`
#'
#' SAS imports missing data as empty strings or strings with whitespaces only. This helper function can be used to
#' convert these values to \code{NA}s.
#'
#' @inheritParams explicit_na
#' @param empty boolean if true empty strings get replaced by \code{NA}
#' @param whitespaces boolean, if true then strings made from whitespaces only get replaced with \code{NA}
#'
#' @export
#'
#' @examples
#' sas_na(c("1", "", " ", "   ", "b"))
#' sas_na(factor(c("", " ", "b")))
#'
#' is.na(sas_na(c("1", "", " ", "   ", "b")))
sas_na <- function(x, empty = TRUE, whitespaces = TRUE) {
  checkmate::assert_flag(empty)
  checkmate::assert_flag(whitespaces)

  if (is.factor(x)) {
    empty_levels <- levels(x) == ""
    if (empty && any(empty_levels)) levels(x)[empty_levels] <- NA

    ws_levels <- grepl("^\\s+$", levels(x))
    if (whitespaces && any(ws_levels)) levels(x)[ws_levels] <- NA

    x
  } else if (is.character(x)) {
    if (empty) x[x == ""] <- NA_character_

    if (whitespaces) x[grepl("^\\s+$", x)] <- NA_character_

    x
  } else {
    stop("only factors and character vectors allowed")
  }
}

#' Helper Functions for Tabulating Biomarker Effects on Binary Response by Subgroup
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Helper functions which are documented here separately to not confuse the user
#' when reading about the user-facing functions.
#'
#' @inheritParams response_biomarkers_subgroups
#' @inheritParams extract_rsp_biomarkers
#' @inheritParams argument_convention
#' @name h_response_biomarkers_subgroups
#'
#' @examples
#' library(dplyr)
#' library(forcats)
#'
#' adrs <- tern_ex_adrs
#' adrs_labels <- formatters::var_labels(adrs)
#'
#' adrs_f <- adrs %>%
#'   filter(PARAMCD == "BESRSPI") %>%
#'   mutate(rsp = AVALC == "CR")
#' formatters::var_labels(adrs_f) <- c(adrs_labels, "Response")
#'
NULL

#' @describeIn h_response_biomarkers_subgroups helps with converting the "response" function variable list
#'   to the "logistic regression" variable list. The reason is that currently there is an
#'   inconsistency between the variable names accepted by `extract_rsp_subgroups()` and `fit_logistic()`.
#' @param biomarker (`string`)\cr the name of the biomarker variable.
#'
#' @examples
#' # This is how the variable list is converted internally.
#' h_rsp_to_logistic_variables(
#'   variables = list(
#'     rsp = "RSP",
#'     covariates = c("A", "B"),
#'     strat = "D"
#'   ),
#'   biomarker = "AGE"
#' )
#'
#' @export
h_rsp_to_logistic_variables <- function(variables, biomarker) {
  checkmate::assert_list(variables)
  checkmate::assert_string(variables$rsp)
  checkmate::assert_string(biomarker)
  list(
    response = variables$rsp,
    arm = biomarker,
    covariates = variables$covariates,
    strata = variables$strat
  )
}

#' @describeIn h_response_biomarkers_subgroups prepares estimates for number of responses, patients and
#'   overall response rate, as well as odds ratio estimates, confidence intervals and p-values, for multiple
#'   biomarkers in a given single data set.
#'   `variables` corresponds to names of variables found in `data`, passed as a named list and requires elements
#'   `rsp` and `biomarkers` (vector of continuous biomarker variables) and optionally `covariates`
#'   and `strat`.
#'
#' @examples
#' # For a single population, estimate separately the effects
#' # of two biomarkers.
#' df <- h_logistic_mult_cont_df(
#'   variables = list(
#'     rsp = "rsp",
#'     biomarkers = c("BMRKR1", "AGE"),
#'     covariates = "SEX"
#'   ),
#'   data = adrs_f
#' )
#' df
#'
#' # If the data set is empty, still the corresponding rows with missings are returned.
#' h_coxreg_mult_cont_df(
#'   variables = list(
#'     rsp = "rsp",
#'     biomarkers = c("BMRKR1", "AGE"),
#'     covariates = "SEX",
#'     strat = "STRATA1"
#'   ),
#'   data = adrs_f[NULL, ]
#' )
#'
#' @export
h_logistic_mult_cont_df <- function(variables,
                                    data,
                                    control = control_logistic()) {
  assert_df_with_variables(data, variables)

  checkmate::assert_character(variables$biomarkers, min.len = 1, any.missing = FALSE)
  checkmate::assert_list(control, names = "named")

  conf_level <- control[["conf_level"]]
  pval_label <- "p-value (Wald)"

  # If there is any data, run model, otherwise return empty results.
  if (nrow(data) > 0) {
    bm_cols <- match(variables$biomarkers, names(data))
    l_result <- lapply(variables$biomarkers, function(bm) {
      model_fit <- fit_logistic(
        variables = h_rsp_to_logistic_variables(variables, bm),
        data = data,
        response_definition = control$response_definition
      )
      result <- h_logistic_simple_terms(
        x = bm,
        fit_glm = model_fit,
        conf_level = control$conf_level
      )
      resp_vector <- if (inherits(model_fit, "glm")) {
        model_fit$model[[variables$rsp]]
      } else {
        as.logical(as.matrix(model_fit$y)[, "status"])
      }
      data.frame(
        # Dummy column needed downstream to create a nested header.
        biomarker = bm,
        biomarker_label = formatters::var_labels(data[bm], fill = TRUE),
        n_tot = length(resp_vector),
        n_rsp = sum(resp_vector),
        prop = mean(resp_vector),
        or = as.numeric(result[1L, "odds_ratio"]),
        lcl = as.numeric(result[1L, "lcl"]),
        ucl = as.numeric(result[1L, "ucl"]),
        conf_level = conf_level,
        pval = as.numeric(result[1L, "pvalue"]),
        pval_label = pval_label,
        stringsAsFactors = FALSE
      )
    })
    do.call(rbind, args = c(l_result, make.row.names = FALSE))
  } else {
    data.frame(
      biomarker = variables$biomarkers,
      biomarker_label = formatters::var_labels(data[variables$biomarkers], fill = TRUE),
      n_tot = 0L,
      n_rsp = 0L,
      prop = NA,
      or = NA,
      lcl = NA,
      ucl = NA,
      conf_level = conf_level,
      pval = NA,
      pval_label = pval_label,
      row.names = seq_along(variables$biomarkers),
      stringsAsFactors = FALSE
    )
  }
}

#' @describeIn h_response_biomarkers_subgroups prepares a single sub-table given a `df_sub` containing
#'   the results for a single biomarker.
#' @param df (`data.frame`)\cr results for a single biomarker, as part of what is
#'   returned by [extract_rsp_biomarkers()] (it needs a couple of columns which are
#'   added by that high-level function relative to what is returned by [h_logistic_mult_cont_df()],
#'   see the example).
#'
#' @examples
#' # Starting from above `df`, zoom in on one biomarker and add required columns.
#' df1 <- df[1, ]
#' df1$subgroup <- "All patients"
#' df1$row_type <- "content"
#' df1$var <- "ALL"
#' df1$var_label <- "All patients"
#'
#' # Internal function - h_tab_rsp_one_biomarker
#' \dontrun{
#' h_tab_rsp_one_biomarker(
#'   df1,
#'   vars = c("n_tot", "n_rsp", "prop", "or", "ci", "pval")
#' )
#' }
#'
#' @export
h_tab_rsp_one_biomarker <- function(df,
                                    vars) {
  afuns <- a_response_subgroups()[vars]
  colvars <- d_rsp_subgroups_colvars(
    vars,
    conf_level = df$conf_level[1],
    method = df$pval_label[1]
  )
  h_tab_one_biomarker(
    df = df,
    afuns = afuns,
    colvars = colvars
  )
}

#' Sort `PK PARAM` variable
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @param pk_data (`data.frame`)\cr Pharmacokinetics dataframe
#' @param key_var (`character`)\cr key variable used to merge pk_data and metadata created by `d_pkparam()`
#' @return dataframe with `PK PARAM` variable ordered
#' @export
#'
#' @examples
#' library(dplyr)
#'
#' adpp <- tern_ex_adpp %>% mutate(PKPARAM = factor(paste0(PARAM, " (", AVALU, ")")))
#' pk_ordered_data <- h_pkparam_sort(adpp)
h_pkparam_sort <- function(pk_data, key_var = "PARAMCD") {
  assert_df_with_variables(pk_data, list(key_var = key_var))
  pk_data$PARAMCD <- pk_data[[key_var]] # nolint

  ordered_pk_data <- d_pkparam()

  # Add the numeric values from ordered_pk_data to pk_data
  joined_data <- merge(pk_data, ordered_pk_data, by = "PARAMCD", suffix = c("", ".y"))

  joined_data <- joined_data[, -grep(".*.y$", colnames(joined_data))]

  joined_data$TLG_ORDER <- as.numeric(joined_data$TLG_ORDER) # nolint

  # Then order PARAM based on this column
  joined_data$PARAM <- factor(joined_data$PARAM, # nolint
    levels = unique(joined_data$PARAM[order(joined_data$TLG_ORDER)]),
    ordered = TRUE
  )

  joined_data$TLG_DISPLAY <- factor(joined_data$TLG_DISPLAY, # nolint
    levels = unique(joined_data$TLG_DISPLAY[order(joined_data$TLG_ORDER)]),
    ordered = TRUE
  )

  joined_data
}

#' Summary numeric variables in columns
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This function can be used to produce summary tables for PK datasets where
#' the relevant statistic is on the columns instead of on the rows.
#'
#' @name analyze_vars_in_cols
#'
NULL

#' @describeIn analyze_vars_in_cols Layout creating
#' function which can be used for creating summary tables in columns, primarily used for PK data sets.
#'
#' @inheritParams argument_convention
#' @inheritParams rtables::analyze_colvars
#'
#' @seealso [summarize_vars], [`rtables::analyze_colvars()`].
#'
#' @export
#' @examples
#' library(dplyr)
#'
#' adpp <- tern_ex_adpp %>% h_pkparam_sort()
#' lyt <- basic_table() %>%
#'   split_rows_by(var = "ARM", label_pos = "topleft") %>%
#'   split_rows_by(var = "SEX", label_pos = "topleft") %>%
#'   analyze_vars_in_cols(vars = "AGE")
#' result <- build_table(lyt = lyt, df = adpp)
#' result
#'
#' # By selecting just some statistics and ad-hoc labels
#' lyt <- basic_table() %>%
#'   split_rows_by(var = "ARM", label_pos = "topleft") %>%
#'   split_rows_by(var = "SEX", label_pos = "topleft") %>%
#'   analyze_vars_in_cols(
#'     vars = "AGE",
#'     .stats = c("n", "cv", "geom_mean", "mean_ci", "median", "min", "max"),
#'     .labels = c(
#'       n = "myN",
#'       cv = "myCV",
#'       geom_mean = "myGeomMean",
#'       mean_ci = "Mean (95%CI)",
#'       median = "Median",
#'       min = "Minimum",
#'       max = "Maximum"
#'     )
#'   )
#' result <- build_table(lyt = lyt, df = adpp)
#' result
#'
#' lyt <- basic_table() %>%
#'   analyze_vars_in_cols(
#'     vars = "AGE",
#'     labelstr = "some custom label"
#'   )
#' result <- build_table(lyt, df = adpp)
#' result
#'
#' # PKPT03
#' lyt <- basic_table() %>%
#'   split_rows_by(var = "TLG_DISPLAY", split_label = "PK Parameter", label_pos = "topleft") %>%
#'   analyze_vars_in_cols(
#'     vars = "AVAL",
#'     .stats = c("n", "mean", "sd", "cv", "geom_mean", "geom_cv", "median", "min", "max"),
#'     .labels = c(
#'       n = "n",
#'       mean = "Mean",
#'       sd = "SD",
#'       cv = "CV (%)",
#'       geom_mean = "Geometric Mean",
#'       geom_cv = "CV % Geometric Mean",
#'       median = "Median",
#'       min = "Minimum",
#'       max = "Maximum"
#'     )
#'   )
#' result <- build_table(lyt, df = adpp)
#' result
analyze_vars_in_cols <- function(lyt,
                                 vars,
                                 ...,
                                 .stats = c(
                                   "n",
                                   "mean",
                                   "sd",
                                   "se",
                                   "cv",
                                   "geom_cv"
                                 ),
                                 .labels = c(
                                   n = "n",
                                   mean = "Mean",
                                   sd = "SD",
                                   se = "SE",
                                   cv = "CV (%)",
                                   geom_cv = "CV % Geometric Mean"
                                 ),
                                 labelstr = " ",
                                 nested = TRUE,
                                 na_level = NULL,
                                 .formats = NULL) {
  checkmate::assert_string(na_level, null.ok = TRUE)
  checkmate::assert_string(labelstr)
  checkmate::assert_flag(nested)

  # Automatic assignment of formats
  if (is.null(.formats)) {
    # General values
    sf_numeric <- summary_formats("numeric")
    sf_counts <- summary_formats("counts")[-1]
    formats_v <- c(sf_numeric, sf_counts)
  } else {
    formats_v <- .formats
  }

  afun_list <- Map(
    function(stat) {
      make_afun(
        s_summary,
        .labels = labelstr,
        .stats = stat,
        .format_na_strs = na_level,
        .formats = formats_v[names(formats_v) == stat]
      )
    },
    stat = .stats
  )

  # Check for vars in the case that one or more are used
  if (length(vars) == 1) {
    vars <- rep(vars, length(.stats))
  } else if (length(vars) != length(.stats)) {
    stop(
      "Analyzed variables (vars) does not have the same ",
      "number of elements of specified statistics (.stats)."
    )
  }

  lyt <- split_cols_by_multivar(
    lyt = lyt,
    vars = vars,
    varlabels = .labels[.stats]
  )

  analyze_colvars(lyt,
    afun = afun_list,
    nested = nested,
    extra_args = list(...)
  )
}

#' Encode Categorical Missing Values in a Data Frame
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This is a helper function to encode missing entries across groups of categorical
#'   variables in a data frame.
#'
#' @details Missing entries are those with `NA` or empty strings and will
#'   be replaced with a specified value. If factor variables include missing
#'   values, the missing value will be inserted as the last level.
#'   Similarly, in case character or logical variables should be converted to factors
#'   with the `char_as_factor` or `logical_as_factor` options, the missing values will
#'   be set as the last level.
#'
#' @param data (`data.frame`)\cr data set.
#' @param omit_columns (`character`)\cr names of variables from `data` that should
#'   not be modified by this function.
#' @param char_as_factor (`flag`)\cr whether to convert character variables
#'   in `data` to factors.
#' @param logical_as_factor (`flag`)\cr whether to convert logical variables
#'   in `data` to factors.
#' @param na_level (`string`)\cr used to replace all `NA` or empty
#'   values inside non-`omit_columns` columns.
#'
#' @return The data frame with the desired changes made.
#'
#' @export
#' @seealso [sas_na()] and [explicit_na()] for other missing data helper functions.
#' @examples
#'
#' my_data <- data.frame(
#'   u = c(TRUE, FALSE, NA, TRUE),
#'   v = factor(c("A", NA, NA, NA), levels = c("Z", "A")),
#'   w = c("A", "B", NA, "C"),
#'   x = c("D", "E", "F", NA),
#'   y = c("G", "H", "I", ""),
#'   z = c(1, 2, 3, 4),
#'   stringsAsFactors = FALSE
#' )
#'
#' # Encode missing values in all character or factor columns.
#' df_explicit_na(my_data)
#' # Also convert logical columns to factor columns.
#' df_explicit_na(my_data, logical_as_factor = TRUE)
#' # Encode missing values in a subset of columns.
#' df_explicit_na(my_data, omit_columns = c("x", "y"))
#'
df_explicit_na <- function(data,
                           omit_columns = NULL,
                           char_as_factor = TRUE,
                           logical_as_factor = FALSE,
                           na_level = "<Missing>") {
  checkmate::assert_character(omit_columns, null.ok = TRUE, min.len = 1, any.missing = FALSE)
  checkmate::assert_data_frame(data)
  checkmate::assert_flag(char_as_factor)
  checkmate::assert_flag(logical_as_factor)
  checkmate::assert_string(na_level)

  target_vars <- if (is.null(omit_columns)) {
    names(data)
  } else {
    setdiff(names(data), omit_columns) # May have duplicates.
  }
  if (length(target_vars) == 0) {
    return(data)
  }

  l_target_vars <- split(target_vars, target_vars)

  # Makes sure target_vars exist in data and names are not duplicated.
  assert_df_with_variables(data, l_target_vars)

  for (x in target_vars) {
    xi <- data[[x]]
    xi_label <- obj_label(xi)

    # Determine whether to convert character or logical input.
    do_char_conversion <- is.character(xi) && char_as_factor
    do_logical_conversion <- is.logical(xi) && logical_as_factor

    # Pre-convert logical to character to deal correctly with replacing NA
    # values below.
    if (do_logical_conversion) {
      xi <- as.character(xi)
    }

    if (is.factor(xi) || is.character(xi)) {
      # Handle empty strings and NA values.
      xi <- explicit_na(sas_na(xi), label = na_level)

      # Convert to factors if requested for the original type,
      # set na_level as the last value.
      if (do_char_conversion || do_logical_conversion) {
        levels_xi <- setdiff(sort(unique(xi)), na_level)
        if (na_level %in% unique(xi)) {
          levels_xi <- c(levels_xi, na_level)
        }

        xi <- factor(xi, levels = levels_xi)
      }

      data[, x] <- formatters::with_label(xi, label = xi_label)
    }
  }
  return(data)
}

#' Convert List of Groups to Data Frame
#'
#' This converts a list of group levels into a data frame format which is expected by
#' [rtables::add_combo_levels()].
#'
#' @param groups_list (named `list` of `character`)\cr specifies the new group levels via the names and the
#'   levels that belong to it in the character vectors that are elements of the list.
#'
#' @return [tibble::tibble()] in the required format.
#'
#' @examples
#' grade_groups <- list(
#'   "Any Grade (%)" = c("1", "2", "3", "4", "5"),
#'   "Grade 3-4 (%)" = c("3", "4"),
#'   "Grade 5 (%)" = "5"
#' )
#' # Internal function - groups_list_to_df
#' \dontrun{
#' groups_list_to_df(grade_groups)
#' }
#'
#' @keywords internal
groups_list_to_df <- function(groups_list) {
  checkmate::assert_list(groups_list, names = "named")
  lapply(groups_list, checkmate::assert_character)
  tibble::tibble(
    valname = make_names(names(groups_list)),
    label = names(groups_list),
    levelcombo = unname(groups_list),
    exargs = replicate(length(groups_list), list())
  )
}


#' Reference and Treatment Group Combination
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Facilitate the re-combination of groups divided as reference and
#' treatment groups; it helps in arranging groups of
#' columns in the `rtables` framework and teal modules.
#'
#' @param fct (`factor`)\cr the variable with levels which needs to be grouped.
#' @param ref (`string`)\cr the reference level(s).
#' @param collapse (`string`)\cr a character string to separate `fct` and `ref`.
#'
#' @return a `list` with first item `ref` (reference) and second item `trt`
#'   (treatment).
#' @export
#'
#' @examples
#' groups <- combine_groups(
#'   fct = DM$ARM,
#'   ref = c("B: Placebo")
#' )
#'
#' basic_table() %>%
#'   split_cols_by_groups("ARM", groups) %>%
#'   add_colcounts() %>%
#'   summarize_vars("AGE") %>%
#'   build_table(DM)
combine_groups <- function(fct,
                           ref = NULL,
                           collapse = "/") {
  checkmate::assert_string(collapse)
  checkmate::assert_character(ref, min.chars = 1, any.missing = FALSE, null.ok = TRUE)
  checkmate::assert_multi_class(fct, classes = c("factor", "character"))

  fct <- as_factor_keep_attributes(fct)

  group_levels <- levels(fct)
  if (is.null(ref)) {
    ref <- group_levels[1]
  } else {
    checkmate::assert_subset(ref, group_levels)
  }

  groups <- list(
    ref = group_levels[group_levels %in% ref],
    trt = group_levels[!group_levels %in% ref]
  )
  stats::setNames(groups, nm = lapply(groups, paste, collapse = collapse))
}

#' Split Columns by Groups of Levels
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @inheritParams argument_convention
#' @inheritParams groups_list_to_df
#' @param ... additional arguments, see _note_ section.
#'
#' @note The ellipse (`...`) conveys arguments to [rtables::split_cols_by()]
#'   in order, for instance, to control formats (`format`), add a joint column
#'   for all groups (`incl_all`).
#'
#' @seealso [rtables::split_cols_by()]
#' @return the modified layout.
#' @export
#'
#' @examples
#' # 1 - Basic use
#'
#' # Without group combination `split_cols_by_groups` is
#' # equivalent to [rtables::split_cols_by()].
#' basic_table() %>%
#'   split_cols_by_groups("ARM") %>%
#'   add_colcounts() %>%
#'   analyze("AGE") %>%
#'   build_table(DM)
#'
#' # Add a reference column.
#' basic_table() %>%
#'   split_cols_by_groups("ARM", ref_group = "B: Placebo") %>%
#'   add_colcounts() %>%
#'   analyze(
#'     "AGE",
#'     afun = function(x, .ref_group, .in_ref_col) {
#'       if (.in_ref_col) {
#'         in_rows("Diff Mean" = rcell(NULL))
#'       } else {
#'         in_rows("Diff Mean" = rcell(mean(x) - mean(.ref_group), format = "xx.xx"))
#'       }
#'     }
#'   ) %>%
#'   build_table(DM)
#'
#' # 2 - Adding group specification
#'
#' # Manual preparation of the groups.
#' groups <- list(
#'   "Arms A+B" = c("A: Drug X", "B: Placebo"),
#'   "Arms A+C" = c("A: Drug X", "C: Combination")
#' )
#'
#' # Use of split_cols_by_groups without reference column.
#' basic_table() %>%
#'   split_cols_by_groups("ARM", groups) %>%
#'   add_colcounts() %>%
#'   analyze("AGE") %>%
#'   build_table(DM)
#'
#' # Including differentiated output in the reference column.
#' basic_table() %>%
#'   split_cols_by_groups("ARM", groups_list = groups, ref_group = "Arms A+B") %>%
#'   analyze(
#'     "AGE",
#'     afun = function(x, .ref_group, .in_ref_col) {
#'       if (.in_ref_col) {
#'         in_rows("Diff. of Averages" = rcell(NULL))
#'       } else {
#'         in_rows("Diff. of Averages" = rcell(mean(x) - mean(.ref_group), format = "xx.xx"))
#'       }
#'     }
#'   ) %>%
#'   build_table(DM)
#'
#' # 3 - Binary list dividing factor levels into reference and treatment
#'
#' # `combine_groups` defines reference and treatment.
#' groups <- combine_groups(
#'   fct = DM$ARM,
#'   ref = c("A: Drug X", "B: Placebo")
#' )
#' groups
#'
#' # Use group definition without reference column.
#' basic_table() %>%
#'   split_cols_by_groups("ARM", groups_list = groups) %>%
#'   add_colcounts() %>%
#'   analyze("AGE") %>%
#'   build_table(DM)
#'
#'
#' # Use group definition with reference column (first item of groups).
#' basic_table() %>%
#'   split_cols_by_groups("ARM", groups, ref_group = names(groups)[1]) %>%
#'   add_colcounts() %>%
#'   analyze(
#'     "AGE",
#'     afun = function(x, .ref_group, .in_ref_col) {
#'       if (.in_ref_col) {
#'         in_rows("Diff Mean" = rcell(NULL))
#'       } else {
#'         in_rows("Diff Mean" = rcell(mean(x) - mean(.ref_group), format = "xx.xx"))
#'       }
#'     }
#'   ) %>%
#'   build_table(DM)
split_cols_by_groups <- function(lyt,
                                 var,
                                 groups_list = NULL,
                                 ref_group = NULL,
                                 ...) {
  if (is.null(groups_list)) {
    split_cols_by(
      lyt = lyt,
      var = var,
      ref_group = ref_group,
      ...
    )
  } else {
    groups_df <- groups_list_to_df(groups_list)
    if (!is.null(ref_group)) {
      ref_group <- groups_df$valname[groups_df$label == ref_group]
    }
    split_cols_by(
      lyt = lyt,
      var = var,
      split_fun = add_combo_levels(groups_df, keep_levels = groups_df$valname),
      ref_group = ref_group,
      ...
    )
  }
}

#' Combine Counts
#'
#' Simplifies the estimation of column counts, especially when group combination
#' is required.
#'
#' @seealso [combine_groups]
#' @inheritParams combine_groups
#' @inheritParams groups_list_to_df
#'
#' @examples
#' ref <- c("A: Drug X", "B: Placebo")
#' groups <- combine_groups(fct = DM$ARM, ref = ref)
#'
#' # Internal function - combine_counts
#' \dontrun{
#' col_counts <- combine_counts(
#'   fct = DM$ARM,
#'   groups_list = groups
#' )
#'
#' basic_table() %>%
#'   split_cols_by_groups("ARM", groups) %>%
#'   add_colcounts() %>%
#'   summarize_vars("AGE") %>%
#'   build_table(DM, col_counts = col_counts)
#'
#' ref <- "A: Drug X"
#' groups <- combine_groups(fct = DM$ARM, ref = ref)
#' col_counts <- combine_counts(
#'   fct = DM$ARM,
#'   groups_list = groups
#' )
#'
#' basic_table() %>%
#'   split_cols_by_groups("ARM", groups) %>%
#'   add_colcounts() %>%
#'   summarize_vars("AGE") %>%
#'   build_table(DM, col_counts = col_counts)
#' }
#'
#' @keywords internal
combine_counts <- function(fct, groups_list = NULL) {
  checkmate::assert_multi_class(fct, classes = c("factor", "character"))

  fct <- as_factor_keep_attributes(fct)

  if (is.null(groups_list)) {
    y <- table(fct)
    y <- stats::setNames(as.numeric(y), nm = dimnames(y)[[1]])
  } else {
    y <- vapply(
      X = groups_list,
      FUN = function(x) sum(table(fct)[x]),
      FUN.VALUE = 1
    )
  }
  y
}

#' Counting Patients and Events in Columns
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Counting the number of unique patients and the total number of all and specific events
#' when a column table layout is required.
#'
#' @name count_patients_events_in_cols
#'
NULL

#' @describeIn count_patients_events_in_cols Statistics function which counts numbers of patients and multiple events
#'   defined by filters.
#'
#' @inheritParams argument_convention
#' @param filters_list (named `list` of `character`)\cr each element in this list describes one
#'   type of event describe by filters, in the same format as [s_count_patients_with_event()].
#'   If it has a label, then this will be used for the column title.
#' @param empty_stats (`character`)\cr optional names of the statistics that should be returned empty such
#'   that corresponding table cells will stay blank.
#' @param custom_label (`string` or `NULL`)\cr if provided and `labelstr` is empty then this will
#'   be used as label.
#'
#' @return [s_count_patients_and_multiple_events()] returns a list with the statistics:
#'   - `unique`: number of unique patients in `df`.
#'   - `all`: number of rows in `df`.
#'   - one element with the same name as in `filters_list`: number of rows in `df`,
#'     i.e. events, fulfilling the filter condition.
#'
#' @examples
#' # `s_count_patients_and_multiple_events()`
#' df <- data.frame(
#'   USUBJID = rep(c("id1", "id2", "id3", "id4"), c(2, 3, 1, 1)),
#'   ARM = c("A", "A", "B", "B", "B", "B", "A"),
#'   AESER = rep("Y", 7),
#'   AESDTH = c("Y", "Y", "N", "Y", "Y", "N", "N"),
#'   AEREL = c("Y", "Y", "N", "Y", "Y", "N", "Y"),
#'   AEDECOD = c("A", "A", "A", "B", "B", "C", "D"),
#'   AEBODSYS = rep(c("SOC1", "SOC2", "SOC3"), c(3, 3, 1))
#' )
#'
#' # Internal function - s_count_patients_and_multiple_events
#' \dontrun{
#' s_count_patients_and_multiple_events(
#'   df = df,
#'   id = "USUBJID",
#'   filters_list = list(
#'     serious = c(AESER = "Y"),
#'     fatal = c(AESDTH = "Y")
#'   )
#' )
#' }
#'
#' @keywords internal
s_count_patients_and_multiple_events <- function(df, # nolint
                                                 id,
                                                 filters_list,
                                                 empty_stats = character(),
                                                 labelstr = "",
                                                 custom_label = NULL) {
  checkmate::assert_list(filters_list, names = "named")
  checkmate::assert_data_frame(df)
  checkmate::assert_string(id)
  checkmate::assert_disjunct(c("unique", "all"), names(filters_list))
  checkmate::assert_character(empty_stats)
  checkmate::assert_string(labelstr)
  checkmate::assert_string(custom_label, null.ok = TRUE)

  # Below we want to count each row in `df` once, therefore introducing this helper index column.
  df$.row_index <- as.character(seq_len(nrow(df)))
  y <- list()
  row_label <- if (labelstr != "") {
    labelstr
  } else if (!is.null(custom_label)) {
    custom_label
  } else {
    "counts"
  }
  y$unique <- formatters::with_label(
    s_num_patients_content(df = df, .N_col = 1, .var = id, required = NULL)$unique[1L],
    row_label
  )
  y$all <- formatters::with_label(
    nrow(df),
    row_label
  )
  events <- Map(
    function(filters) {
      formatters::with_label(
        s_count_patients_with_event(df = df, .var = ".row_index", filters = filters, .N_col = 1, .N_row = 1)$count,
        row_label
      )
    },
    filters = filters_list
  )
  y_complete <- c(y, events)
  y <- if (length(empty_stats) > 0) {
    y_reduced <- y_complete
    for (stat in intersect(names(y_complete), empty_stats)) {
      y_reduced[[stat]] <- formatters::with_label(character(), obj_label(y_reduced[[stat]]))
    }
    y_reduced
  } else {
    y_complete
  }
  y
}

#' @describeIn count_patients_events_in_cols Layout creating function which adds the count
#'   statistics of patients and events in the column layout as content rows.
#'
#' @inheritParams argument_convention
#' @param col_split (`flag`)\cr whether the columns should be split.
#'  Set to `FALSE` when the required column split has been done already earlier in the layout pipe.
#' @export
#' @examples
#'
#' # `summarize_patients_events_in_cols()`
#' basic_table() %>%
#'   summarize_patients_events_in_cols(
#'     filters_list = list(
#'       related = formatters::with_label(c(AEREL = "Y"), "Events (Related)"),
#'       fatal = c(AESDTH = "Y"),
#'       fatal_related = c(AEREL = "Y", AESDTH = "Y")
#'     ),
#'     custom_label = "%s Total number of patients and events"
#'   ) %>%
#'   build_table(df)
summarize_patients_events_in_cols <- function(lyt, # nolint
                                              id = "USUBJID",
                                              filters_list = list(),
                                              ...,
                                              .stats = c(
                                                "unique",
                                                "all",
                                                names(filters_list)
                                              ),
                                              .labels = c(
                                                unique = "Patients (All)",
                                                all = "Events (All)",
                                                labels_or_names(filters_list)
                                              ),
                                              col_split = TRUE) {
  afun_list <- Map(
    function(stat) {
      make_afun(
        s_count_patients_and_multiple_events,
        id = id,
        filters_list = filters_list,
        .stats = stat,
        .formats = "xx."
      )
    },
    stat = .stats
  )
  if (col_split) {
    lyt <- split_cols_by_multivar(
      lyt = lyt,
      vars = rep(id, length(.stats)),
      varlabels = .labels[.stats]
    )
  }
  summarize_row_groups(
    lyt = lyt,
    cfun = afun_list,
    extra_args = list(...)
  )
}

#' Summary for analysis of covariance (ANCOVA).
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Summarize results of ANCOVA. This can be used to analyze multiple endpoints and/or
#' multiple timepoints within the same response variable `.var`.
#'
#' @name summarize_ancova
NULL

#' Helper Function to Return Results of a Linear Model
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @inheritParams argument_convention
#' @param .df_row (`data.frame`)\cr data set that includes all the variables that are called
#'   in `.var` and `variables`.
#' @param variables (named `list` of `strings`)\cr list of additional analysis variables, with
#'   expected elements:
#'   - `arm` (`string`)\cr group variable, for which the covariate adjusted means of multiple
#'     groups will be summarized. Specifically, the first level of `arm` variable is taken as the
#'     reference group.
#'   - `covariates` (`character`)\cr a vector that can contain single variable names (such as
#'     `"X1"`), and/or interaction terms indicated by `"X1 * X2"`.
#' @param interaction_item (`character`)\cr name of the variable that should have interactions
#'   with arm. if the interaction is not needed, the default option is NULL.
#'
#' @examples
#' h_ancova(
#'   .var = "Sepal.Length",
#'   .df_row = iris,
#'   variables = list(arm = "Species", covariates = c("Petal.Length * Petal.Width", "Sepal.Width"))
#' )
#'
#' @export
h_ancova <- function(.var,
                     .df_row,
                     variables,
                     interaction_item = NULL) {
  checkmate::assert_string(.var)
  checkmate::assert_list(variables)
  checkmate::assert_subset(names(variables), c("arm", "covariates"))
  assert_df_with_variables(.df_row, list(rsp = .var))

  arm <- variables$arm
  covariates <- variables$covariates
  if (!is.null(covariates) && length(covariates) > 0) {
    # Get all covariate variable names in the model.
    var_list <- get_covariates(covariates)
    assert_df_with_variables(.df_row, var_list)
  }

  covariates_part <- paste(covariates, collapse = " + ")
  if (covariates_part != "") {
    formula <- stats::as.formula(paste0(.var, " ~ ", covariates_part, " + ", arm))
  } else {
    formula <- stats::as.formula(paste0(.var, " ~ ", arm))
  }

  if (is.null(interaction_item)) {
    specs <- arm
  } else {
    specs <- c(arm, interaction_item)
  }

  lm_fit <- stats::lm(
    formula = formula,
    data = .df_row
  )
  emmeans_fit <- emmeans::emmeans(
    lm_fit,
    # Specify here the group variable over which EMM are desired.
    specs = specs,
    # Pass the data again so that the factor levels of the arm variable can be inferred.
    data = .df_row
  )

  emmeans_fit
}

#' @describeIn summarize_ancova Statistics function that produces a named list of results
#'   of the investigated linear model.
#'
#' @inheritParams argument_convention
#' @inheritParams h_ancova
#' @param interaction_y (`character`)\cr a selected item inside of the interaction_item column
#'   which will be used to select the specific ANCOVA results. if the interaction is not
#'   needed, the default option is FALSE
#' @return A named list of 5 statistics:
#' \describe{
#'   \item{n}{count of complete sample size for the group.}
#'   \item{lsmean}{estimated marginal means in the group.}
#'   \item{lsmean_diff}{difference in estimated marginal means in comparison to the reference group.
#'     If working with the reference group, this will be empty.
#'   }
#'   \item{lsmean_diff_ci}{confidence level for difference in estimated marginal means in comparison to the
#'     reference group.
#'   }
#'   \item{pval}{p-value (not adjusted for multiple comparisons).}
#' }
#'
#' @examples
#' library(dplyr)
#'
#' df <- iris %>% filter(Species == "virginica")
#' .df_row <- iris
#' .var <- "Petal.Length"
#' variables <- list(arm = "Species", covariates = "Sepal.Length * Sepal.Width")
#' .ref_group <- iris %>% filter(Species == "setosa")
#' conf_level <- 0.95
#'
#' # Internal function - s_ancova
#' \dontrun{
#' s_ancova(
#'   df, .var, .df_row, variables, .ref_group,
#'   .in_ref_col = FALSE,
#'   conf_level, interaction_y = FALSE, interaction_item = NULL
#' )
#' }
#'
#' @keywords internal
s_ancova <- function(df,
                     .var,
                     .df_row,
                     variables,
                     .ref_group,
                     .in_ref_col,
                     conf_level,
                     interaction_y = FALSE,
                     interaction_item = NULL) {
  emmeans_fit <- h_ancova(.var = .var, variables = variables, .df_row = .df_row, interaction_item = interaction_item)

  sum_fit <- summary(
    emmeans_fit,
    level = conf_level
  )

  arm <- variables$arm

  sum_level <- as.character(unique(df[[arm]]))

  # Ensure that there is only one element in sum_level.
  checkmate::assert_scalar(sum_level)

  sum_fit_level <- sum_fit[sum_fit[[arm]] == sum_level, ]

  # Get the index of the ref arm
  if (interaction_y != FALSE) {
    y <- unlist(df[(df[[interaction_item]] == interaction_y), .var])
    # convert characters selected in interaction_y into the numeric order
    interaction_y <- which(sum_fit_level[[interaction_item]] == interaction_y)
    sum_fit_level <- sum_fit_level[interaction_y, ]
    # if interaction is called, reset the index
    ref_key <- seq(sum_fit[[arm]][unique(.ref_group[[arm]])])
    ref_key <- tail(ref_key, n = 1)
    ref_key <- (interaction_y - 1) * length(unique(.df_row[[arm]])) + ref_key
  } else {
    y <- df[[.var]]
    # Get the index of the ref arm when interaction is not called
    ref_key <- seq(sum_fit[[arm]][unique(.ref_group[[arm]])])
    ref_key <- tail(ref_key, n = 1)
  }

  if (.in_ref_col) {
    list(
      n = length(y[!is.na(y)]),
      lsmean = formatters::with_label(sum_fit_level$emmean, "Adjusted Mean"),
      lsmean_diff = formatters::with_label(character(), "Difference in Adjusted Means"),
      lsmean_diff_ci = formatters::with_label(character(), f_conf_level(conf_level)),
      pval = formatters::with_label(character(), "p-value")
    )
  } else {
    # Estimate the differences between the marginal means.
    emmeans_contrasts <- emmeans::contrast(
      emmeans_fit,
      # Compare all arms versus the control arm.
      method = "trt.vs.ctrl",
      # Take the arm factor from .ref_group as the control arm.
      ref = ref_key,
      level = conf_level
    )
    sum_contrasts <- summary(
      emmeans_contrasts,
      # Derive confidence intervals, t-tests and p-values.
      infer = TRUE,
      # Do not adjust the p-values for multiplicity.
      adjust = "none"
    )

    sum_contrasts_level <- sum_contrasts[grepl(sum_level, sum_contrasts$contrast), ]
    if (interaction_y != FALSE) {
      sum_contrasts_level <- sum_contrasts_level[interaction_y, ]
    }

    list(
      n = length(y[!is.na(y)]),
      lsmean = formatters::with_label(sum_fit_level$emmean, "Adjusted Mean"),
      lsmean_diff = formatters::with_label(sum_contrasts_level$estimate, "Difference in Adjusted Means"),
      lsmean_diff_ci = formatters::with_label(
        c(sum_contrasts_level$lower.CL, sum_contrasts_level$upper.CL),
        f_conf_level(conf_level)
      ),
      pval = formatters::with_label(sum_contrasts_level$p.value, "p-value")
    )
  }
}

#' @describeIn summarize_ancova Formatted Analysis function which can be further customized by calling
#'   [rtables::make_afun()] on it. It is used as `afun` in [rtables::analyze()].
#'
#' @examples
#' # Internal function - a_ancova
#' \dontrun{
#' a_ancova(
#'   df, .var, .df_row, variables, .ref_group,
#'   .in_ref_col = FALSE,
#'   interaction_y = FALSE, interaction_item = NULL, conf_level
#' )
#' }
#'
#' @keywords internal
a_ancova <- make_afun(
  s_ancova,
  .indent_mods = c("n" = 0L, "lsmean" = 0L, "lsmean_diff" = 0L, "lsmean_diff_ci" = 1L, "pval" = 1L),
  .formats = c(
    "n" = "xx",
    "lsmean" = "xx.xx",
    "lsmean_diff" = "xx.xx",
    "lsmean_diff_ci" = "(xx.xx, xx.xx)",
    "pval" = "x.xxxx | (<0.0001)"
  ),
  .null_ref_cells = FALSE
)

#' @describeIn summarize_ancova Layout creating function which can be be used for creating
#'   summary tables for analysis of covariance (ANCOVA).
#' @inheritParams argument_convention
#' @export
#'
#' @examples
#' basic_table() %>%
#'   split_cols_by("Species", ref_group = "setosa") %>%
#'   add_colcounts() %>%
#'   summarize_ancova(
#'     vars = "Petal.Length",
#'     variables = list(arm = "Species", covariates = NULL),
#'     table_names = "unadj",
#'     conf_level = 0.95, var_labels = "Unadjusted comparison",
#'     .labels = c(lsmean = "Mean", lsmean_diff = "Difference in Means")
#'   ) %>%
#'   summarize_ancova(
#'     vars = "Petal.Length",
#'     variables = list(arm = "Species", covariates = c("Sepal.Length", "Sepal.Width")),
#'     table_names = "adj",
#'     conf_level = 0.95, var_labels = "Adjusted comparison (covariates: Sepal.Length and Sepal.Width)"
#'   ) %>%
#'   build_table(iris)
summarize_ancova <- function(lyt,
                             vars,
                             var_labels,
                             ...,
                             show_labels = "visible",
                             table_names = vars,
                             .stats = NULL,
                             .formats = NULL,
                             .labels = NULL,
                             .indent_mods = NULL,
                             interaction_y = FALSE,
                             interaction_item = NULL) {
  afun <- make_afun(
    a_ancova,
    interaction_y = interaction_y,
    interaction_item = interaction_item,
    .stats = .stats,
    .formats = .formats,
    .labels = .labels,
    .indent_mods = .indent_mods
  )

  analyze(
    lyt,
    vars,
    var_labels = var_labels,
    show_labels = show_labels,
    table_names = table_names,
    afun = afun,
    extra_args = list(...)
  )
}

#' Create a STEP Graph
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Based on the STEP results, creates a `ggplot` graph showing the estimated HR or OR
#' along the continuous biomarker value subgroups.
#'
#' @param df (`tibble`)\cr result of [tidy.step()].
#' @param use_percentile (`flag`)\cr whether to use percentiles for the x axis or actual
#'   biomarker values.
#' @param est (named `list`)\cr `col` and `lty` settings for estimate line.
#' @param ci_ribbon (named `list` or `NULL`)\cr `fill` and `alpha` settings for the confidence interval
#'   ribbon area, or `NULL` to not plot a CI ribbon.
#' @param col (`character`)\cr colors.
#'
#' @return The `ggplot2` object.
#' @seealso Custom tidy method [tidy.step()].
#' @export
#'
#' @examples
#' library(nestcolor)
#' library(survival)
#' lung$sex <- factor(lung$sex)
#'
#' # Survival example.
#' vars <- list(
#'   time = "time",
#'   event = "status",
#'   arm = "sex",
#'   biomarker = "age"
#' )
#'
#' step_matrix <- fit_survival_step(
#'   variables = vars,
#'   data = lung,
#'   control = c(control_coxph(), control_step(num_points = 10, degree = 2))
#' )
#' step_data <- broom::tidy(step_matrix)
#'
#' # Default plot.
#' g_step(step_data)
#'
#' # Add the reference 1 horizontal line.
#' library(ggplot2)
#' g_step(step_data) +
#'   ggplot2::geom_hline(ggplot2::aes(yintercept = 1), linetype = 2)
#'
#' # Use actual values instead of percentiles, different color for estimate and no CI,
#' # use log scale for y axis.
#' g_step(
#'   step_data,
#'   use_percentile = FALSE,
#'   est = list(col = "blue", lty = 1),
#'   ci_ribbon = NULL
#' ) + scale_y_log10()
#'
#' # Adding another curve based on additional column.
#' step_data$extra <- exp(step_data$`Percentile Center`)
#' g_step(step_data) +
#'   ggplot2::geom_line(ggplot2::aes(y = extra), linetype = 2, color = "green")
#'
#' # Response example.
#' vars <- list(
#'   response = "status",
#'   arm = "sex",
#'   biomarker = "age"
#' )
#'
#' step_matrix <- fit_rsp_step(
#'   variables = vars,
#'   data = lung,
#'   control = c(
#'     control_logistic(response_definition = "I(response == 2)"),
#'     control_step()
#'   )
#' )
#' step_data <- broom::tidy(step_matrix)
#' g_step(step_data)
g_step <- function(df,
                   use_percentile = "Percentile Center" %in% names(df),
                   est = list(col = "blue", lty = 1),
                   ci_ribbon = list(fill = getOption("ggplot2.discrete.colour")[1], alpha = 0.5),
                   col = getOption("ggplot2.discrete.colour")) {
  checkmate::assert_tibble(df)
  checkmate::assert_flag(use_percentile)
  checkmate::assert_character(col, null.ok = TRUE)
  checkmate::assert_list(est, names = "named")
  checkmate::assert_list(ci_ribbon, names = "named", null.ok = TRUE)

  x_var <- ifelse(use_percentile, "Percentile Center", "Interval Center")
  df$x <- df[[x_var]]
  attrs <- attributes(df)
  df$y <- df[[attrs$estimate]]

  # Set legend names. To be modified also at call level
  legend_names <- c("Estimate", "CI 95%")

  p <- ggplot2::ggplot(df, ggplot2::aes(x = .data[["x"]], y = .data[["y"]]))

  if (!is.null(col)) {
    p <- p +
      ggplot2::scale_color_manual(values = col)
  }

  if (!is.null(ci_ribbon)) {
    if (is.null(ci_ribbon$fill)) {
      ci_ribbon$fill <- "lightblue"
    }
    p <- p + ggplot2::geom_ribbon(
      ggplot2::aes(
        ymin = .data[["ci_lower"]], ymax = .data[["ci_upper"]],
        fill = legend_names[2]
      ),
      alpha = ci_ribbon$alpha
    ) +
      scale_fill_manual(
        name = "", values = c("CI 95%" = ci_ribbon$fill)
      )
  }
  suppressMessages(p <- p +
    ggplot2::geom_line(
      ggplot2::aes(y = .data[["y"]], color = legend_names[1]),
      linetype = est$lty
    ) +
    scale_colour_manual(
      name = "", values = c("Estimate" = "blue")
    ))

  p <- p + ggplot2::labs(x = attrs$biomarker, y = attrs$estimate)
  if (use_percentile) {
    p <- p + ggplot2::scale_x_continuous(labels = scales::percent)
  }
  p
}

#' Custom Tidy Method for STEP Results
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Tidy the STEP results into a `tibble` format ready for plotting.
#'
#' @param x (`step` matrix)\cr results from [fit_survival_step()].
#' @param ... not used here.
#' @return A `tibble` with one row per STEP subgroup. The estimates and CIs are on the HR or OR scale,
#'   respectively. Additional attributes carry meta data also used for plotting.
#' @seealso [g_step()] which consumes the result from this function.
#' @method tidy step
#' @export
#'
#' @examples
#' library(survival)
#' lung$sex <- factor(lung$sex)
#' vars <- list(
#'   time = "time",
#'   event = "status",
#'   arm = "sex",
#'   biomarker = "age"
#' )
#' step_matrix <- fit_survival_step(
#'   variables = vars,
#'   data = lung,
#'   control = c(control_coxph(), control_step(num_points = 10, degree = 2))
#' )
#' broom::tidy(step_matrix)
tidy.step <- function(x, ...) { # nolint
  checkmate::assert_class(x, "step")
  dat <- as.data.frame(x)
  nams <- names(dat)
  is_surv <- "loghr" %in% names(dat)
  est_var <- ifelse(is_surv, "loghr", "logor")
  new_est_var <- ifelse(is_surv, "Hazard Ratio", "Odds Ratio")
  new_y_vars <- c(new_est_var, c("ci_lower", "ci_upper"))
  names(dat)[match(est_var, nams)] <- new_est_var
  dat[, new_y_vars] <- exp(dat[, new_y_vars])
  any_is_na <- any(is.na(dat[, new_y_vars]))
  any_is_very_large <- any(abs(dat[, new_y_vars]) > 1e10, na.rm = TRUE)
  if (any_is_na) {
    warning(paste(
      "Missing values in the point estimate or CI columns,",
      "this will lead to holes in the `g_step()` plot"
    ))
  }
  if (any_is_very_large) {
    warning(paste(
      "Very large absolute values in the point estimate or CI columns,",
      "consider adding `scale_y_log10()` to the `g_step()` result for plotting"
    ))
  }
  if (any_is_na || any_is_very_large) {
    warning("Consider using larger `bandwidth`, less `num_points` in `control_step()` settings for fitting")
  }
  structure(
    tibble::as_tibble(dat),
    estimate = new_est_var,
    biomarker = attr(x, "variables")$biomarker,
    ci = f_conf_level(attr(x, "control")$conf_level)
  )
}

#' Count the Number of Patients with a Particular Event
#'
#' The primary analysis variable `.var` denotes the unique patient identifier.
#'
#' @name count_patients_with_event
#'
#' @description `r lifecycle::badge("stable")`
NULL

#' @describeIn count_patients_with_event Statistics Function that returns the number and the fraction
#'   of unique identifiers with a particular type of event, e.g. the number and the fraction of patients who
#'   had treatment-emergent adverse events. Note that the user can define a new data column containing
#'   the event of interest.
#' @inheritParams argument_convention
#' @param .var (`character`)\cr name of the column that contains the unique identifier.
#' @param filters (`character`)\cr a character vector specifying the column names and flag variables
#'   to be used for counting the number of unique identifiers satisfying such conditions.
#'   Multiple column names and flags are accepted in this format
#'   `c("column_name1" = "flag1", "column_name2" = "flag2")`.
#'   Note that only equality is being accepted as condition.
#' @inheritParams summarize_variables
#'
#' @return [s_count_patients_with_event()] returns the count and fraction of patients with the
#'   defined event.
#'
#' @export
#'
#' @examples
#' library(dplyr)
#'
#' # `s_count_patients_with_event()`
#'
#' s_count_patients_with_event(
#'   tern_ex_adae,
#'   .var = "SUBJID",
#'   filters = c("TRTEMFL" = "Y")
#' )
#' s_count_patients_with_event(
#'   tern_ex_adae,
#'   .var = "SUBJID",
#'   filters = c("TRTEMFL" = "Y", "AEOUT" = "FATAL")
#' )
#' s_count_patients_with_event(
#'   tern_ex_adae,
#'   .var = "SUBJID",
#'   filters = c("TRTEMFL" = "Y", "AEOUT" = "FATAL"),
#'   denom = "N_col",
#'   .N_col = 456
#' )
s_count_patients_with_event <- function(df,
                                        .var,
                                        filters,
                                        .N_col, # nolint
                                        .N_row, # nolint
                                        denom = c("n", "N_row", "N_col")) {
  col_names <- names(filters)
  filter_values <- filters

  checkmate::assert_subset(col_names, colnames(df))

  temp <- Map(
    function(x, y) which(df[[x]] == y),
    col_names,
    filter_values
  )
  position_satisfy_filters <- Reduce(intersect, temp)
  id_satisfy_filters <- as.character(unique(df[position_satisfy_filters, ][[.var]]))
  result <- s_count_values(
    as.character(unique(df[[.var]])),
    id_satisfy_filters,
    denom = denom,
    .N_col = .N_col,
    .N_row = .N_row
  )
  result
}

#' @describeIn count_patients_with_event Formatted Analysis function which can be further
#'   customized by calling [rtables::make_afun()] on it. It is used as `afun` in [rtables::analyze()].
#' @export
#'
#' @examples
#' # `a_count_patients_with_event()`
#'
#' a_count_patients_with_event(
#'   tern_ex_adae,
#'   .var = "SUBJID",
#'   filters = c("TRTEMFL" = "Y"),
#'   .N_col = 100,
#'   .N_row = 100
#' )
a_count_patients_with_event <- make_afun(
  s_count_patients_with_event,
  .formats = c(count_fraction = format_count_fraction_fixed_dp)
)

#' @describeIn count_patients_with_event Analyze Function which adds the count statistics
#' to the input layout. Note that additional formatting arguments can be used here.
#'
#' @inheritParams argument_convention
#'
#' @export
#' @examples
#' # `count_patients_with_event()`
#'
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   add_colcounts() %>%
#'   count_values(
#'     "STUDYID",
#'     values = "AB12345",
#'     .stats = "count",
#'     .labels = c(count = "Total AEs")
#'   ) %>%
#'   count_patients_with_event(
#'     "SUBJID",
#'     filters = c("TRTEMFL" = "Y"),
#'     .labels = c(count_fraction = "Total number of patients with at least one adverse event"),
#'     table_names = "tbl_all"
#'   ) %>%
#'   count_patients_with_event(
#'     "SUBJID",
#'     filters = c("TRTEMFL" = "Y", "AEOUT" = "FATAL"),
#'     .labels = c(count_fraction = "Total number of patients with fatal AEs"),
#'     table_names = "tbl_fatal"
#'   ) %>%
#'   count_patients_with_event(
#'     "SUBJID",
#'     filters = c("TRTEMFL" = "Y", "AEOUT" = "FATAL", "AEREL" = "Y"),
#'     .labels = c(count_fraction = "Total number of patients with related fatal AEs"),
#'     .indent_mods = c(count_fraction = 2L),
#'     table_names = "tbl_rel_fatal"
#'   )
#' build_table(lyt, tern_ex_adae, alt_counts_df = tern_ex_adsl)
count_patients_with_event <- function(lyt,
                                      vars,
                                      ...,
                                      table_names = vars,
                                      .stats = "count_fraction",
                                      .formats = NULL,
                                      .labels = NULL,
                                      .indent_mods = NULL) {
  afun <- make_afun(
    a_count_patients_with_event,
    .stats = .stats,
    .formats = .formats,
    .labels = .labels,
    .indent_mods = .indent_mods
  )

  analyze(
    lyt,
    vars,
    afun = afun,
    extra_args = list(...),
    show_labels = ifelse(length(vars) > 1, "visible", "hidden"),
    table_names = table_names
  )
}

#' @describeIn count_patients_with_event Statistics function that returns the number and the fraction
#'   of unique identifiers with each particular flag. Returns a list of totals, counts, counts and
#'   fractions with one element per flag.
#' @inheritParams argument_convention
#' @param .var (`character`)\cr name of the column that contains the unique identifier.
#' @param flag_variables (`character`)\cr a character vector specifying the names of `logical`
#'   variables from analysis dataset used for counting the number of unique identifiers.
#' @inheritParams summarize_variables
#' @export
#'
#' @examples
#' # `s_count_patients_with_flags()`
#'
#' # Add labelled flag variables to analysis dataset.
#' adae <- tern_ex_adae %>%
#'   mutate(
#'     fl1 = TRUE,
#'     fl2 = TRTEMFL == "Y",
#'     fl3 = TRTEMFL == "Y" & AEOUT == "FATAL",
#'     fl4 = TRTEMFL == "Y" & AEOUT == "FATAL" & AEREL == "Y"
#'   )
#' labels <- c(
#'   "fl1" = "Total AEs",
#'   "fl2" = "Total number of patients with at least one adverse event",
#'   "fl3" = "Total number of patients with fatal AEs",
#'   "fl4" = "Total number of patients with related fatal AEs"
#' )
#' formatters::var_labels(adae)[names(labels)] <- labels
#'
#' s_count_patients_with_flags(
#'   adae,
#'   "SUBJID",
#'   flag_variables = c("fl1", "fl2", "fl3", "fl4"),
#'   denom = "N_col",
#'   .N_col = 1000
#' )
s_count_patients_with_flags <- function(df,
                                        .var,
                                        flag_variables,
                                        .N_col, # nolint
                                        .N_row, # nolint
                                        denom = c("n", "N_row", "N_col")) {
  if (is.null(names(flag_variables))) flag_variables <- stats::setNames(flag_variables, flag_variables)
  flag_names <- unname(flag_variables)
  flag_variables <- names(flag_variables)

  checkmate::assert_subset(flag_variables, colnames(df))
  temp <- sapply(flag_variables, function(x) {
    tmp <- Map(function(y) which(df[[y]]), x)
    position_satisfy_flags <- Reduce(intersect, tmp)
    id_satisfy_flags <- as.character(unique(df[position_satisfy_flags, ][[.var]]))
    s_count_values(
      as.character(unique(df[[.var]])),
      id_satisfy_flags,
      denom = denom,
      .N_col = .N_col,
      .N_row = .N_row
    )
  })
  colnames(temp) <- flag_names
  temp <- data.frame(t(temp))
  result <- temp %>% as.list()
  if (length(flag_variables) == 1) {
    for (i in 1:3) names(result[[i]]) <- flag_names[1]
  }
  result
}

#' @describeIn count_patients_with_event Formatted Analysis function which can be further customized by calling
#'   [rtables::make_afun()] on it. It is used as `afun` in [rtables::analyze()].
#' @export
#'
#' @examples
#' #  We need to ungroup `count_fraction` first so that the `rtables` formatting
#' # function `format_count_fraction()` can be applied correctly.
#'
#' # `a_count_patients_with_flags()`
#'
#' afun <- make_afun(a_count_patients_with_flags,
#'   .stats = "count_fraction",
#'   .ungroup_stats = "count_fraction"
#' )
#' afun(
#'   adae,
#'   .N_col = 10L, # nolint
#'   .N_row = 10L,
#'   .var = "USUBJID",
#'   flag_variables = c("fl1", "fl2", "fl3", "fl4")
#' )
a_count_patients_with_flags <- make_afun(
  s_count_patients_with_flags,
  .formats = c("count_fraction" = format_count_fraction_fixed_dp)
)

#' @describeIn count_patients_with_event Analyze Function which is a modified version of [count_patients_with_event()].
#'  Adds the count statistics to the input layout for multiple flag variables at once.
#'
#' @inheritParams argument_convention
#'
#' @export
#'
#' @examples
#' # `count_patients_with_flags()`
#'
#' lyt2 <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   add_colcounts() %>%
#'   count_patients_with_flags(
#'     "SUBJID",
#'     flag_variables = formatters::var_labels(adae[, c("fl1", "fl2", "fl3", "fl4")]),
#'     denom = "N_col"
#'   )
#' build_table(lyt2, adae, alt_counts_df = tern_ex_adsl)
count_patients_with_flags <- function(lyt,
                                      var,
                                      var_labels = var,
                                      show_labels = "hidden",
                                      ...,
                                      table_names = paste0("tbl_flags_", var),
                                      .stats = "count_fraction",
                                      .formats = NULL,
                                      .indent_mods = NULL) {
  afun <- make_afun(
    a_count_patients_with_flags,
    .stats = .stats,
    .formats = .formats,
    .indent_mods = .indent_mods,
    .ungroup_stats = .stats
  )

  lyt <- analyze(
    lyt = lyt,
    vars = var,
    var_labels = var_labels,
    show_labels = show_labels,
    afun = afun,
    table_names = table_names,
    extra_args = list(...)
  )

  lyt
}

#' Summarize the Change from Baseline or Absolute Baseline Values
#'
#' @description `r lifecycle::badge("stable")`
#'
#' The primary analysis variable `.var` indicates the numerical change from baseline results,
#' and additional required secondary analysis variables are `value` and `baseline_flag`.
#' Depending on the baseline flag, either the absolute baseline values (at baseline)
#' or the change from baseline values (post-baseline) are then summarized.
#'
#' @name summarize_change
#'
NULL

#' @inheritParams argument_convention
#' @describeIn summarize_change Statistics Function that summarizes baseline or post-baseline visits.
#' @return See [s_summary.numeric()] for the return values.
#' @note The data in `df` must be either all be from baseline or post-baseline visits. Otherwise
#'   an error will be thrown.
#'
#' @examples
#' df <- data.frame(
#'   chg = c(1, 2, 3),
#'   is_bl = c(TRUE, TRUE, TRUE),
#'   val = c(4, 5, 6)
#' )
#'
#' # Internal function - s_change_from_baseline
#' \dontrun{
#' s_change_from_baseline(
#'   df,
#'   .var = "chg",
#'   variables = list(value = "val", baseline_flag = "is_bl")
#' )
#' }
#'
#' @keywords internal
s_change_from_baseline <- function(df,
                                   .var,
                                   variables,
                                   na.rm = TRUE, # nolint
                                   ...) {
  checkmate::assert_numeric(df[[variables$value]])
  checkmate::assert_numeric(df[[.var]])
  checkmate::assert_logical(df[[variables$baseline_flag]])
  checkmate::assert_vector(unique(df[[variables$baseline_flag]]), max.len = 1)
  assert_df_with_variables(df, c(variables, list(chg = .var)))

  combined <- ifelse(
    df[[variables$baseline_flag]],
    df[[variables$value]],
    df[[.var]]
  )
  if (is.logical(combined) && identical(length(combined), 0L)) {
    combined <- numeric(0)
  }
  s_summary(combined, na.rm = na.rm, ...)
}

#' @describeIn summarize_change Formatted Analysis function which can be further customized by calling
#'   [rtables::make_afun()] on it. It is used as `afun` in [rtables::analyze()].
#'
#' @examples
#' # Internal function - a_change_from_baseline
#' \dontrun{
#' a_change_from_baseline(
#'   df,
#'   .var = "chg",
#'   variables = list(value = "val", baseline_flag = "is_bl")
#' )
#' }
#'
#' @keywords internal
a_change_from_baseline <- make_afun(
  s_change_from_baseline,
  .formats = c(
    n = "xx",
    mean_sd = "xx.xx (xx.xx)",
    mean_se = "xx.xx (xx.xx)",
    median = "xx.xx",
    range = "xx.xx - xx.xx",
    mean_ci = "(xx.xx, xx.xx)",
    median_ci = "(xx.xx, xx.xx)",
    mean_pval = "xx.xx"
  ),
  .labels = c(
    mean_sd = "Mean (SD)",
    mean_se = "Mean (SE)",
    median = "Median",
    range = "Min - Max"
  )
)

#' @describeIn summarize_change Analyze Function for change from baseline analysis.
#'   To be used after a split on visits in the layout, such that each data
#'   subset only contains either baseline or post-baseline data. Allows additional
#'   formatting options.
#' @inheritParams argument_convention
#'
#' @export
#' @examples
#'
#' # `summarize_change()`
#'
#' ## Fabricated dataset.
#' library(dplyr)
#'
#' dta_test <- data.frame(
#'   USUBJID = rep(1:6, each = 3),
#'   AVISIT = rep(paste0("V", 1:3), 6),
#'   ARM = rep(LETTERS[1:3], rep(6, 3)),
#'   AVAL = c(9:1, rep(NA, 9))
#' ) %>%
#'   mutate(ABLFLL = AVISIT == "V1") %>%
#'   group_by(USUBJID) %>%
#'   mutate(
#'     BLVAL = AVAL[ABLFLL],
#'     CHG = AVAL - BLVAL
#'   ) %>%
#'   ungroup()
#'
#' results <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   split_rows_by("AVISIT") %>%
#'   summarize_change("CHG", variables = list(value = "AVAL", baseline_flag = "ABLFLL")) %>%
#'   build_table(dta_test)
#' \dontrun{
#' Viewer(results)
#' }
#'
summarize_change <- function(lyt,
                             vars,
                             ...,
                             table_names = vars,
                             .stats = c("n", "mean_sd", "median", "range"),
                             .formats = NULL,
                             .labels = NULL,
                             .indent_mods = NULL) {
  afun <- make_afun(
    a_change_from_baseline,
    .stats = .stats,
    .formats = .formats,
    .labels = .labels,
    .indent_mods = .indent_mods
  )

  analyze(
    lyt,
    vars,
    afun = afun,
    extra_args = list(...),
    table_names = table_names
  )
}

#' Survival Time Point Analysis
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Summarize patients' survival rate and difference of survival rates between groups at a time point.
#'
#' @inheritParams argument_convention
#' @inheritParams s_surv_time
#' @param time_point (`number`)\cr survival time point of interest.
#' @param control (`list`)\cr parameters for comparison details, specified by using the helper function
#'   [control_surv_timepoint()]. Some possible parameter options are:
#'   * `conf_level` (`proportion`)\cr confidence level of the interval for survival rate.
#'   * `conf_type` (`string`)\cr confidence interval type. Options are "plain" (default), "log", "log-log",
#'     see more in [survival::survfit()]. Note option "none" is no longer supported.
#'   * `time_point` (`number`)\cr survival time point of interest.
#'
#' @name survival_timepoint
NULL

#' @describeIn survival_timepoint Statistics Function which analyzes survival rate.
#'
#' @return The statistics are:
#' \describe{
#'   \item{pt_at_risk}{patients remaining at risk.}
#'   \item{event_free_rate}{event free rate (%).}
#'   \item{rate_se}{standard error of event free rate.}
#'   \item{rate_ci}{confidence interval for event free rate.}
#' }
#'
#' @examples
#' library(dplyr)
#'
#' adtte_f <- tern_ex_adtte %>%
#'   filter(PARAMCD == "OS") %>%
#'   mutate(
#'     AVAL = day2month(AVAL),
#'     is_event = CNSR == 0
#'   )
#' df <- adtte_f %>%
#'   filter(ARMCD == "ARM A")
#'
#' # Internal function - s_surv_timepoint
#' \dontrun{
#' s_surv_timepoint(df, .var = "AVAL", time_point = 7, is_event = "is_event")
#' }
#'
#' @keywords internal
s_surv_timepoint <- function(df,
                             .var,
                             time_point,
                             is_event,
                             control = control_surv_timepoint()) {
  checkmate::assert_string(.var)
  assert_df_with_variables(df, list(tte = .var, is_event = is_event))
  checkmate::assert_numeric(df[[.var]], min.len = 1, any.missing = FALSE)
  checkmate::assert_number(time_point)
  checkmate::assert_logical(df[[is_event]], min.len = 1, any.missing = FALSE)

  conf_type <- control$conf_type
  conf_level <- control$conf_level

  formula <- stats::as.formula(paste0("survival::Surv(", .var, ", ", is_event, ") ~ 1"))
  srv_fit <- survival::survfit(
    formula = formula,
    data = df,
    conf.int = conf_level,
    conf.type = conf_type
  )
  s_srv_fit <- summary(srv_fit, times = time_point, extend = TRUE)
  df_srv_fit <- as.data.frame(s_srv_fit[c("time", "n.risk", "surv", "lower", "upper", "std.err")])
  if (df_srv_fit[["n.risk"]] == 0) {
    pt_at_risk <- event_free_rate <- rate_se <- NA_real_
    rate_ci <- c(NA_real_, NA_real_)
  } else {
    pt_at_risk <- df_srv_fit$n.risk
    event_free_rate <- df_srv_fit$surv
    rate_se <- df_srv_fit$std.err
    rate_ci <- c(df_srv_fit$lower, df_srv_fit$upper)
  }
  list(
    pt_at_risk = formatters::with_label(pt_at_risk, "Patients remaining at risk"),
    event_free_rate = formatters::with_label(event_free_rate * 100, "Event Free Rate (%)"),
    rate_se = formatters::with_label(rate_se * 100, "Standard Error of Event Free Rate"),
    rate_ci = formatters::with_label(rate_ci * 100, f_conf_level(conf_level))
  )
}

#' @describeIn survival_timepoint Formatted Analysis function which can be further customized by calling
#'   [rtables::make_afun()] on it. It is used as `afun` in [rtables::analyze()].
#'
#' @examples
#' # Internal function - a_surv_timepoint
#' \dontrun{
#' a_surv_timepoint(df, .var = "AVAL", time_point = 7, is_event = "is_event")
#' }
#'
#' @keywords internal
a_surv_timepoint <- make_afun(
  s_surv_timepoint,
  .indent_mods = c(
    pt_at_risk = 0L,
    event_free_rate = 0L,
    rate_se = 1L,
    rate_ci = 1L
  ),
  .formats = c(
    pt_at_risk = "xx",
    event_free_rate = "xx.xx",
    rate_se = "xx.xx",
    rate_ci = "(xx.xx, xx.xx)"
  )
)

#' @describeIn survival_timepoint Statistics Function which analyzes difference between two survival rates.
#'
#' @return The statistics are:
#' \describe{
#'   \item{rate_diff}{event free rate difference between two groups.}
#'   \item{rate_diff_ci}{confidence interval for the difference.}
#'   \item{ztest_pval}{p-value to test the difference is 0.}
#' }
#'
#' @examples
#' df_ref_group <- adtte_f %>%
#'   filter(ARMCD == "ARM B")
#'
#' # Internal function - s_surv_timepoint_diff
#' \dontrun{
#' s_surv_timepoint_diff(df, df_ref_group, .in_ref_col = TRUE, .var = "AVAL", is_event = "is_event")
#' s_surv_timepoint_diff(
#'   df,
#'   df_ref_group,
#'   .in_ref_col = FALSE,
#'   .var = "AVAL",
#'   time_point = 7,
#'   is_event = "is_event"
#' )
#' }
#'
#' @keywords internal
s_surv_timepoint_diff <- function(df,
                                  .var,
                                  .ref_group,
                                  .in_ref_col,
                                  time_point,
                                  control = control_surv_timepoint(),
                                  ...) {
  if (.in_ref_col) {
    return(
      list(
        rate_diff = formatters::with_label("", "Difference in Event Free Rate"),
        rate_diff_ci = formatters::with_label("", f_conf_level(control$conf_level)),
        ztest_pval = formatters::with_label("", "p-value (Z-test)")
      )
    )
  }
  data <- rbind(.ref_group, df)
  group <- factor(rep(c("ref", "x"), c(nrow(.ref_group), nrow(df))), levels = c("ref", "x"))
  res_per_group <- lapply(split(data, group), function(x) {
    s_surv_timepoint(df = x, .var = .var, time_point = time_point, control = control, ...)
  })

  res_x <- res_per_group[[2]]
  res_ref <- res_per_group[[1]]
  rate_diff <- res_x$event_free_rate - res_ref$event_free_rate
  se_diff <- sqrt(res_x$rate_se^2 + res_ref$rate_se^2)

  qs <- c(-1, 1) * stats::qnorm(1 - (1 - control$conf_level) / 2)
  rate_diff_ci <- rate_diff + qs * se_diff
  ztest_pval <- if (is.na(rate_diff)) {
    NA
  } else {
    2 * (1 - stats::pnorm(abs(rate_diff) / se_diff))
  }
  list(
    rate_diff = formatters::with_label(rate_diff, "Difference in Event Free Rate"),
    rate_diff_ci = formatters::with_label(rate_diff_ci, f_conf_level(control$conf_level)),
    ztest_pval = formatters::with_label(ztest_pval, "p-value (Z-test)")
  )
}

#' @describeIn survival_timepoint Formatted Analysis function which can be further customized by calling
#'   [rtables::make_afun()] on it. It is used as `afun` in [rtables::analyze()].
#'
#' @examples
#' # Internal function - a_surv_timepoint_diff
#' \dontrun{
#' a_surv_timepoint_diff(
#'   df,
#'   df_ref_group,
#'   .in_ref_col = FALSE,
#'   .var = "AVAL",
#'   time_point = 7,
#'   is_event = "is_event"
#' )
#' }
#'
#' @keywords internal
a_surv_timepoint_diff <- make_afun(
  s_surv_timepoint_diff,
  .indent_mods = c(
    rate_diff = 1L,
    rate_diff_ci = 2L,
    ztest_pval = 2L
  ),
  .formats = c(
    rate_diff = "xx.xx",
    rate_diff_ci = "(xx.xx, xx.xx)",
    ztest_pval = "x.xxxx | (<0.0001)"
  )
)

#' @describeIn survival_timepoint Analyze Function which adds the survival rate analysis to the input layout.
#'   Note that additional formatting arguments can be used here.
#'
#' @inheritParams argument_convention
#' @param method (`string`)\cr either `surv` (survival estimations),
#'   `surv_diff` (difference in survival with the control) or `both`.
#' @param table_names_suffix (`string`)\cr optional suffix for the `table_names` used for the `rtables` to
#'   avoid warnings from duplicate table names.
#' @export
#'
#' @examples
#' # Survival at given time points.
#' basic_table() %>%
#'   split_cols_by(var = "ARMCD", ref_group = "ARM A") %>%
#'   add_colcounts() %>%
#'   surv_timepoint(
#'     vars = "AVAL",
#'     var_labels = "Months",
#'     is_event = "is_event",
#'     time_point = 7
#'   ) %>%
#'   build_table(df = adtte_f)
#'
#' # Difference in survival at given time points.
#' basic_table() %>%
#'   split_cols_by(var = "ARMCD", ref_group = "ARM A") %>%
#'   add_colcounts() %>%
#'   surv_timepoint(
#'     vars = "AVAL",
#'     var_labels = "Months",
#'     is_event = "is_event",
#'     time_point = 9,
#'     method = "surv_diff",
#'     .indent_mods = c("rate_diff" = 0L, "rate_diff_ci" = 2L, "ztest_pval" = 2L)
#'   ) %>%
#'   build_table(df = adtte_f)
#'
#' # Survival and difference in survival at given time points.
#' basic_table() %>%
#'   split_cols_by(var = "ARMCD", ref_group = "ARM A") %>%
#'   add_colcounts() %>%
#'   surv_timepoint(
#'     vars = "AVAL",
#'     var_labels = "Months",
#'     is_event = "is_event",
#'     time_point = 9,
#'     method = "both"
#'   ) %>%
#'   build_table(df = adtte_f)
surv_timepoint <- function(lyt,
                           vars,
                           ...,
                           table_names_suffix = "",
                           var_labels = "Time",
                           show_labels = "visible",
                           method = c("surv", "surv_diff", "both"),
                           .stats = c(
                             "pt_at_risk", "event_free_rate", "rate_ci",
                             "rate_diff", "rate_diff_ci", "ztest_pval"
                           ),
                           .formats = NULL,
                           .labels = NULL,
                           .indent_mods = NULL) {
  method <- match.arg(method)
  checkmate::assert_string(table_names_suffix)

  f <- list(
    surv = c("pt_at_risk", "event_free_rate", "rate_se", "rate_ci"),
    surv_diff = c("rate_diff", "rate_diff_ci", "ztest_pval")
  )
  .stats <- h_split_param(.stats, .stats, f = f)
  .formats <- h_split_param(.formats, names(.formats), f = f)
  .labels <- h_split_param(.labels, names(.labels), f = f)
  .indent_mods <- h_split_param(.indent_mods, names(.indent_mods), f = f)

  afun_surv <- make_afun(
    a_surv_timepoint,
    .stats = .stats$surv,
    .formats = .formats$surv,
    .labels = .labels$surv,
    .indent_mods = .indent_mods$surv
  )

  afun_surv_diff <- make_afun(
    a_surv_timepoint_diff,
    .stats = .stats$surv_diff,
    .formats = .formats$surv_diff,
    .labels = .labels$surv_diff,
    .indent_mods = .indent_mods$surv_diff
  )

  time_point <- list(...)$time_point

  for (i in seq_along(time_point)) {
    tpt <- time_point[i]

    if (method %in% c("surv", "both")) {
      lyt <- analyze(
        lyt,
        vars,
        var_labels = paste(tpt, var_labels),
        table_names = paste0("surv_", tpt, table_names_suffix),
        show_labels = show_labels,
        afun = afun_surv,
        extra_args = list(
          is_event = list(...)$is_event,
          control = list(...)$control,
          time_point = tpt
        )
      )
    }

    if (method %in% c("surv_diff", "both")) {
      lyt <- analyze(
        lyt,
        vars,
        var_labels = paste(tpt, var_labels),
        table_names = paste0("surv_diff_", tpt, table_names_suffix),
        show_labels = ifelse(method == "both", "hidden", show_labels),
        afun = afun_surv_diff,
        extra_args = list(
          is_event = list(...)$is_event,
          control = list(...)$control,
          time_point = tpt
        )
      )
    }
  }
  lyt
}

#' Survival Time Analysis
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Summarize median survival time and CIs, percentiles of survival times, survival
#' time range of censored/event patients.
#'
#' @inheritParams argument_convention
#' @param control (`list`)\cr parameters for comparison details, specified by using the helper function
#'   [control_surv_time()]. Some possible parameter options are:
#'   * `conf_level` (`proportion`)\cr confidence level of the interval for survival time.
#'   * `conf_type` (`string`)\cr confidence interval type. Options are "plain" (default), "log", or "log-log",
#'     see more in [survival::survfit()]. Note option "none" is not supported.
#'   * `quantiles` (`numeric`)\cr vector of length two to specify the quantiles of survival time.
#'
#' @name survival_time
NULL

#' @describeIn survival_time Statistics Function which analyzes survival times.
#'  `range_censor` and `range_event`.
#'
#' @return The statistics are:
#' \describe{
#'   \item{median}{median survival time.}
#'   \item{median_ci}{confidence interval for median time.}
#'   \item{quantiles}{survival time for two specified quantiles.}
#'   \item{range_censor}{survival time range for censored observations.}
#'   \item{range_event}{survival time range for observations with events.}
#'   \item{range}{survival time range for all observations.}
#' }
#'
#' @examples
#' library(dplyr)
#'
#' adtte_f <- tern_ex_adtte %>%
#'   filter(PARAMCD == "OS") %>%
#'   mutate(
#'     AVAL = day2month(AVAL),
#'     is_event = CNSR == 0
#'   )
#' df <- adtte_f %>% filter(ARMCD == "ARM A")
#'
#' # Internal function - s_surv_time
#' \dontrun{
#' s_surv_time(df, .var = "AVAL", is_event = "is_event")
#' }
#'
#' @keywords internal
s_surv_time <- function(df,
                        .var,
                        is_event,
                        control = control_surv_time()) {
  checkmate::assert_string(.var)
  assert_df_with_variables(df, list(tte = .var, is_event = is_event))
  checkmate::assert_numeric(df[[.var]], min.len = 1, any.missing = FALSE)
  checkmate::assert_logical(df[[is_event]], min.len = 1, any.missing = FALSE)

  conf_type <- control$conf_type
  conf_level <- control$conf_level
  quantiles <- control$quantiles

  formula <- stats::as.formula(paste0("survival::Surv(", .var, ", ", is_event, ") ~ 1"))
  srv_fit <- survival::survfit(
    formula = formula,
    data = df,
    conf.int = conf_level,
    conf.type = conf_type
  )
  srv_tab <- summary(srv_fit, extend = TRUE)$table
  srv_qt_tab <- stats::quantile(srv_fit, probs = quantiles)$quantile
  range_censor <- range_noinf(df[[.var]][!df[[is_event]]], na.rm = TRUE)
  range_event <- range_noinf(df[[.var]][df[[is_event]]], na.rm = TRUE)
  range <- range_noinf(df[[.var]], na.rm = TRUE)
  list(
    median = formatters::with_label(unname(srv_tab["median"]), "Median"),
    median_ci = formatters::with_label(
      unname(srv_tab[paste0(srv_fit$conf.int, c("LCL", "UCL"))]), f_conf_level(conf_level)
    ),
    quantiles = formatters::with_label(
      unname(srv_qt_tab), paste0(quantiles[1] * 100, "% and ", quantiles[2] * 100, "%-ile")
    ),
    range_censor = formatters::with_label(range_censor, "Range (censored)"),
    range_event = formatters::with_label(range_event, "Range (event)"),
    range = formatters::with_label(range, "Range")
  )
}

#' @describeIn survival_time Formatted Analysis function which can be further customized by calling
#'   [rtables::make_afun()] on it. It is used as `afun` in [rtables::analyze()].
#'
#' @examples
#' # Internal function - a_surv_time
#' \dontrun{
#' a_surv_time(df, .var = "AVAL", is_event = "is_event")
#' }
#'
#' @keywords internal
a_surv_time <- make_afun(
  s_surv_time,
  .indent_mods = c(
    "median" = 0L,
    "median_ci" = 1L,
    "quantiles" = 0L,
    "range_censor" = 0L,
    "range_event" = 0L,
    "range" = 0L
  ),
  .formats = c(
    "median" = "xx.x",
    "median_ci" = "(xx.x, xx.x)",
    "quantiles" = "xx.x, xx.x",
    "range_censor" = "xx.x to xx.x",
    "range_event" = "xx.x to xx.x",
    "range" = "xx.x to xx.x"
  )
)

#' @describeIn survival_time Analyze Function which adds the survival times analysis
#'   to the input layout. Note that additional formatting arguments can be used here.
#'
#' @export
#'
#' @examples
#' basic_table() %>%
#'   split_cols_by(var = "ARMCD") %>%
#'   add_colcounts() %>%
#'   surv_time(
#'     vars = "AVAL",
#'     var_labels = "Survival Time (Months)",
#'     is_event = "is_event",
#'     control = control_surv_time(conf_level = 0.9, conf_type = "log-log")
#'   ) %>%
#'   build_table(df = adtte_f)
surv_time <- function(lyt,
                      vars,
                      ...,
                      var_labels = "Time to Event",
                      table_names = vars,
                      .stats = c("median", "median_ci", "quantiles", "range_censor", "range_event"),
                      .formats = NULL,
                      .labels = NULL,
                      .indent_mods = NULL) {
  afun <- make_afun(
    a_surv_time,
    .stats = .stats,
    .formats = .formats,
    .labels = .labels,
    .indent_mods = .indent_mods
  )
  analyze(
    lyt,
    vars,
    var_labels = var_labels,
    show_labels = "visible",
    table_names = table_names,
    afun = afun,
    extra_args = list(...)
  )
}

#' Estimation of Proportions per Level of Factor
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Estimate the proportion along with confidence interval of a proportion
#' regarding the level of a factor.
#'
#' @seealso Relevant description function [d_onco_rsp_label()].
#'
#' @name estimate_multinomial_rsp
#'
NULL

#' Description of Standard Oncology Response
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Describe the oncology response in a standard way.
#'
#' @param x (`character`)\cr the standard oncology code to be described.
#' @seealso [estimate_multinomial_rsp()]
#' @export
#'
#' @examples
#' d_onco_rsp_label(
#'   c("CR", "PR", "SD", "NON CR/PD", "PD", "NE", "Missing", "<Missing>", "NE/Missing")
#' )
#'
#' # Adding some values not considered in d_onco_rsp_label
#'
#' d_onco_rsp_label(
#'   c("CR", "PR", "hello", "hi")
#' )
d_onco_rsp_label <- function(x) { # nolint

  x <- as.character(x)
  desc <- c(
    CR           = "Complete Response (CR)",
    Missing      = "Missing",
    MR           = "Minimal/Minor Response (MR)",
    MRD          = "Minimal Residual Disease (MRD)",
    `NA`         = "Not Applicable (NA)",
    ND           = "Not Done (ND)",
    NE           = "Not Evaluable (NE)",
    `NE/Missing` = "Missing or unevaluable",
    `NON CR/PD`  = "Non-CR or Non-PD (NON CR/PD)",
    PD           = "Progressive Disease (PD)",
    PR           = "Partial Response (PR)",
    SD           = "Stable Disease (SD)"
  )

  values_label <- vapply(
    X = x,
    FUN.VALUE = character(1),
    function(val) {
      if (val %in% names(desc)) desc[val] else val
    }
  )

  return(factor(values_label))
}


#' @describeIn estimate_multinomial_rsp Statistics function which takes the length of the input `x` and takes that
#'   as the number of successes, and the column number `.N_col` as the total number, and feeds that into
#'   [s_proportion()].
#' @inheritParams argument_convention
#' @return See [s_proportion()] for statistics and additional possible arguments.
#'
#' @export
#'
#' @examples
#' s_length_proportion(rep("CR", 10), .N_col = 100)
#' s_length_proportion(factor(character(0)), .N_col = 100)
s_length_proportion <- function(x,
                                .N_col, # nolint snake_case
                                ...) {
  checkmate::assert_multi_class(x, classes = c("factor", "character"))
  checkmate::assert_vector(x, min.len = 0, max.len = .N_col)
  checkmate::assert_vector(unique(x), min.len = 0, max.len = 1)

  n_true <- length(x)
  n_false <- .N_col - n_true
  x_logical <- rep(c(TRUE, FALSE), c(n_true, n_false))
  s_proportion(df = x_logical, ...)
}

#' @describeIn estimate_multinomial_rsp Formatted Analysis function which can be further customized by calling
#'   [rtables::make_afun()] on it. It is used as `afun` in [rtables::analyze()].
#' @export
#'
#' @examples
#' a_length_proportion(rep("CR", 10), .N_col = 100)
#' a_length_proportion(factor(character(0)), .N_col = 100)
a_length_proportion <- make_afun(
  s_length_proportion,
  .formats = c(
    n_prop = "xx (xx.x%)",
    prop_ci = "(xx.xx, xx.xx)"
  )
)

#' @describeIn estimate_multinomial_rsp Analyze Function which adds the multinomial proportion analysis to
#'   the input layout. Note that additional formatting arguments can be used
#'   here.
#' @inheritParams argument_convention
#'
#' @export
#'
#' @examples
#' library(dplyr)
#'
#' # Use of the layout creating function.
#' dta_test <- data.frame(
#'   USUBJID = paste0("S", 1:12),
#'   ARM     = factor(rep(LETTERS[1:3], each = 4)),
#'   AVAL    = c(A = c(1, 1, 1, 1), B = c(0, 0, 1, 1), C = c(0, 0, 0, 0))
#' ) %>% mutate(
#'   AVALC = factor(AVAL,
#'     levels = c(0, 1),
#'     labels = c("Complete Response (CR)", "Partial Response (PR)")
#'   )
#' )
#'
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   estimate_multinomial_response(var = "AVALC")
#'
#' tbl <- build_table(lyt, dta_test)
#'
#' html <- as_html(tbl)
#' html
#' \dontrun{
#' Viewer(html)
#' }
estimate_multinomial_response <- function(lyt,
                                          var,
                                          ...,
                                          show_labels = "hidden",
                                          table_names = var,
                                          .stats = "prop_ci",
                                          .formats = NULL,
                                          .labels = NULL,
                                          .indent_mods = NULL) {
  afun <- make_afun(
    a_length_proportion,
    .stats = .stats,
    .formats = .formats,
    .labels = .labels,
    .indent_mods = .indent_mods
  )
  lyt <- split_rows_by(lyt, var = var)
  lyt <- summarize_row_groups(lyt)

  analyze(
    lyt,
    vars = var,
    afun = afun,
    show_labels = show_labels,
    table_names = table_names,
    extra_args = list(...)
  )
}

#' Confidence Interval for Mean
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Convenient function for calculating the mean confidence interval.
#' It calculates the arithmetic as well as the geometric mean.
#' It can be used as a `ggplot` helper function for plotting.
#'
#' @inheritParams argument_convention
#' @param n_min (`number`)\cr a minimum number of non-missing `x` to estimate
#'     the confidence interval for mean.
#' @param gg_helper (`logical`)\cr `TRUE` when output should be aligned
#' for the use with `ggplot`.
#' @param geom_mean (`logical`)\cr `TRUE` when the geometric mean should be
#' calculated
#'
#' @export
#'
#' @examples
#'
#' stat_mean_ci(sample(10), gg_helper = FALSE)
#'
#' p <- ggplot2::ggplot(mtcars, ggplot2::aes(cyl, mpg)) +
#'   ggplot2::geom_point()
#'
#' p + ggplot2::stat_summary(
#'   fun.data = stat_mean_ci,
#'   geom = "errorbar"
#' )
#'
#' p + ggplot2::stat_summary(
#'   fun.data = stat_mean_ci,
#'   fun.args = list(conf_level = 0.5),
#'   geom = "errorbar"
#' )
#'
#' p + ggplot2::stat_summary(
#'   fun.data = stat_mean_ci,
#'   fun.args = list(conf_level = 0.5, geom_mean = TRUE),
#'   geom = "errorbar"
#' )
stat_mean_ci <- function(x,
                         conf_level = 0.95,
                         na.rm = TRUE, # nolint
                         n_min = 2,
                         gg_helper = TRUE,
                         geom_mean = FALSE) {
  if (na.rm) {
    x <- stats::na.omit(x)
  }
  n <- length(x)

  if (!geom_mean) {
    m <- mean(x)
  } else {
    negative_values_exist <- any(is.na(x[!is.na(x)]) <- x[!is.na(x)] <= 0)
    if (negative_values_exist) {
      m <- NA_real_
    } else {
      x <- log(x)
      m <- mean(x)
    }
  }

  if (n < n_min || is.na(m)) {
    ci <- c(mean_ci_lwr = NA_real_, mean_ci_upr = NA_real_)
  } else {
    hci <- stats::qt((1 + conf_level) / 2, df = n - 1) * stats::sd(x) / sqrt(n)
    ci <- c(mean_ci_lwr = m - hci, mean_ci_upr = m + hci)
    if (geom_mean) {
      ci <- exp(ci)
    }
  }

  if (gg_helper) {
    m <- ifelse(is.na(m), NA_real_, m)
    ci <- data.frame(y = ifelse(geom_mean, exp(m), m), ymin = ci[[1]], ymax = ci[[2]])
  }

  return(ci)
}

#' Confidence Interval for Median
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Convenient function for calculating the median confidence interval.
#' It can be used as a `ggplot` helper function for plotting.
#'
#' @inheritParams argument_convention
#' @param gg_helper (`logical`)\cr `TRUE` when output should be aligned
#' for the use with `ggplot`.
#'
#' @details The function was adapted from `DescTools/versions/0.99.35/source`
#'
#' @export
#'
#' @examples
#'
#' stat_median_ci(sample(10), gg_helper = FALSE)
#'
#' p <- ggplot2::ggplot(mtcars, ggplot2::aes(cyl, mpg)) +
#'   ggplot2::geom_point()
#' p + ggplot2::stat_summary(
#'   fun.data = stat_median_ci,
#'   geom = "errorbar"
#' )
stat_median_ci <- function(x,
                           conf_level = 0.95,
                           na.rm = TRUE, # nolint
                           gg_helper = TRUE) {
  x <- unname(x)
  if (na.rm) {
    x <- x[!is.na(x)]
  }
  n <- length(x)
  med <- stats::median(x)

  k <- stats::qbinom(p = (1 - conf_level) / 2, size = n, prob = 0.5, lower.tail = TRUE)

  # k == 0 - for small samples (e.g. n <= 5) ci can be outside the observed range
  if (k == 0 || is.na(med)) {
    ci <- c(median_ci_lwr = NA_real_, median_ci_upr = NA_real_)
    empir_conf_level <- NA_real_
  } else {
    x_sort <- sort(x)
    ci <- c(median_ci_lwr = x_sort[k], median_ci_upr = x_sort[n - k + 1])
    empir_conf_level <- 1 - 2 * stats::pbinom(k - 1, size = n, prob = 0.5)
  }

  if (gg_helper) {
    ci <- data.frame(y = med, ymin = ci[[1]], ymax = ci[[2]])
  }

  attr(ci, "conf_level") <- empir_conf_level

  return(ci)
}

#' p-Value of the Mean
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Convenient function for calculating the two-sided p-value of the mean.
#'
#' @inheritParams argument_convention
#' @param n_min (`number`)\cr a minimum number of non-missing `x` to estimate
#'     the p-value of the mean.
#' @param test_mean (`number`)\cr mean value to test under the null hypothesis.
#'
#' @examples
#' stat_mean_pval(sample(10))
#'
#' stat_mean_pval(rnorm(10), test_mean = 0.5)
#'
#' @export
stat_mean_pval <- function(x,
                           na.rm = TRUE, # nolint
                           n_min = 2,
                           test_mean = 0) {
  if (na.rm) {
    x <- stats::na.omit(x)
  }
  n <- length(x)

  x_mean <- mean(x)
  x_sd <- stats::sd(x)

  if (n < n_min) {
    pv <- c(p_value = NA_real_)
  } else {
    x_se <- stats::sd(x) / sqrt(n)
    ttest <- (x_mean - test_mean) / x_se
    pv <- c(p_value = 2 * stats::pt(-abs(ttest), df = n - 1))
  }

  return(pv)
}

#' Individual Patient Plots
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Line plot(s) displaying trend in patients' parameter values over time is rendered.
#' Patients' individual baseline values can be added to the plot(s) as reference.
#'
#' @inheritParams argument_convention
#' @param xvar (`string`)\cr time point variable to be plotted on x-axis.
#' @param yvar (`string`)\cr continuous analysis variable to be plotted on y-axis.
#' @param xlab (`string`)\cr plot label for x-axis.
#' @param ylab (`string`)\cr plot label for y-axis.
#' @param id_var (`string`)\cr variable used as patient identifier.
#' @param title (`string`)\cr title for plot.
#' @param subtitle (`string`)\cr subtitle for plot.
#' @param add_baseline_hline (`flag`)\cr adds horizontal line at baseline y-value on
#' plot when TRUE.
#' @param yvar_baseline (`string`)\cr variable with baseline values only.
#' Ignored when `add_baseline_hline` is FALSE.
#' @param ggtheme (`theme`)\cr optional graphical theme function as provided
#' by `ggplot2` to control outlook of plot. Use `ggplot2::theme()` to tweak the display.
#' @param plotting_choices (`character`)\cr specifies options for displaying
#' plots. Must be one of "all_in_one", "split_by_max_obs", "separate_by_obs".
#' @param max_obs_per_plot (`count`)\cr Number of observations to be plotted on one
#' plot. Ignored when `plotting_choices` is not "separate_by_obs".
#' @param caption (`character` scalar)\cr optional caption below the plot.
#' @param col (`character`)\cr lines colors.
#'
#' @seealso Relevant helper function [h_g_ipp()].
#'
#' @name individual_patient_plot
NULL

#' Helper Function To Create Simple Line Plot over Time
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Function that generates a simple line plot displaying parameter trends over time.
#'
#' @inheritParams argument_convention
#' @inheritParams g_ipp
#' @seealso [g_ipp()] which uses this function.
#' @export
#' @examples
#' library(dplyr)
#' library(nestcolor)
#'
#' # Select a small sample of data to plot.
#' adlb <- tern_ex_adlb %>%
#'   filter(PARAMCD == "ALT", !(AVISIT %in% c("SCREENING", "BASELINE"))) %>%
#'   slice(1:36)
#'
#' p <- h_g_ipp(
#'   df = adlb,
#'   xvar = "AVISIT",
#'   yvar = "AVAL",
#'   xlab = "Visit",
#'   id_var = "USUBJID",
#'   ylab = "SGOT/ALT (U/L)",
#'   add_baseline_hline = TRUE
#' )
#' p
h_g_ipp <- function(df,
                    xvar,
                    yvar,
                    xlab,
                    ylab,
                    id_var,
                    title = "Individual Patient Plots",
                    subtitle = "",
                    caption = NULL,
                    add_baseline_hline = FALSE,
                    yvar_baseline = "BASE",
                    ggtheme = nestcolor::theme_nest(),
                    col = NULL) {
  checkmate::assert_string(xvar)
  checkmate::assert_string(yvar)
  checkmate::assert_string(yvar_baseline)
  checkmate::assert_string(id_var)
  checkmate::assert_string(xlab)
  checkmate::assert_string(ylab)
  checkmate::assert_string(title)
  checkmate::assert_string(subtitle)
  checkmate::assert_subset(c(xvar, yvar, yvar_baseline, id_var), colnames(df))
  checkmate::assert_data_frame(df)
  checkmate::assert_flag(add_baseline_hline)
  checkmate::assert_character(col, null.ok = TRUE)

  p <- ggplot2::ggplot(
    data = df,
    mapping = ggplot2::aes(
      x = .data[[xvar]],
      y = .data[[yvar]],
      group = .data[[id_var]],
      colour = .data[[id_var]]
    )
  ) +
    ggplot2::geom_line(linewidth = 0.4) +
    ggplot2::geom_point(size = 2) +
    ggplot2::labs(
      x = xlab,
      y = ylab,
      title = title,
      subtitle = subtitle,
      caption = caption
    ) +
    ggtheme

  if (add_baseline_hline) {
    baseline_df <- df[, c(id_var, yvar_baseline)]
    baseline_df <- unique(baseline_df)

    p <- p +
      ggplot2::geom_hline(
        data = baseline_df,
        mapping = ggplot2::aes(
          yintercept = .data[[yvar_baseline]],
          colour = .data[[id_var]]
        ),
        linetype = "dotdash",
        linewidth = 0.4
      ) +
      ggplot2::geom_text(
        data = baseline_df,
        mapping = ggplot2::aes(
          x = 1,
          y = .data[[yvar_baseline]],
          label = .data[[id_var]],
          colour = .data[[id_var]]
        ),
        nudge_y = 0.025 * (max(df[, yvar], na.rm = TRUE) - min(df[, yvar], na.rm = TRUE)),
        vjust = "right",
        size = 2
      )

    if (!is.null(col)) {
      p <- p +
        ggplot2::scale_color_manual(values = col)
    }
  }
  p
}

#' Plotting Function for Individual Patient Plot
#'
#' @describeIn individual_patient_plot depending on user preference, renders a single
#' graphic or compiles a list of graphics that show trends in individual's parameter
#' values over time.
#'
#' @return a `ggplot` object or a list of `ggplot` objects.
#'
#' @export
#' @examples
#' library(dplyr)
#' library(nestcolor)
#'
#' # Select a small sample of data to plot.
#' adlb <- tern_ex_adlb %>%
#'   filter(PARAMCD == "ALT", !(AVISIT %in% c("SCREENING", "BASELINE"))) %>%
#'   slice(1:36)
#'
#' plot_list <- g_ipp(
#'   df = adlb,
#'   xvar = "AVISIT",
#'   yvar = "AVAL",
#'   xlab = "Visit",
#'   ylab = "SGOT/ALT (U/L)",
#'   title = "Individual Patient Plots",
#'   add_baseline_hline = TRUE,
#'   plotting_choices = "split_by_max_obs",
#'   max_obs_per_plot = 5
#' )
#' plot_list
g_ipp <- function(df,
                  xvar,
                  yvar,
                  xlab,
                  ylab,
                  id_var = "USUBJID",
                  title = "Individual Patient Plots",
                  subtitle = "",
                  caption = NULL,
                  add_baseline_hline = FALSE,
                  yvar_baseline = "BASE",
                  ggtheme = nestcolor::theme_nest(),
                  plotting_choices = c("all_in_one", "split_by_max_obs", "separate_by_obs"),
                  max_obs_per_plot = 4,
                  col = NULL) {
  checkmate::assert_count(max_obs_per_plot)
  checkmate::assert_subset(plotting_choices, c("all_in_one", "split_by_max_obs", "separate_by_obs"))
  checkmate::assert_character(col, null.ok = TRUE)

  plotting_choices <- match.arg(plotting_choices)

  if (plotting_choices == "all_in_one") {
    p <- h_g_ipp(
      df = df,
      xvar = xvar,
      yvar = yvar,
      xlab = xlab,
      ylab = ylab,
      id_var = id_var,
      title = title,
      subtitle = subtitle,
      caption = caption,
      add_baseline_hline = add_baseline_hline,
      yvar_baseline = yvar_baseline,
      ggtheme = ggtheme,
      col = col
    )

    return(p)
  } else if (plotting_choices == "split_by_max_obs") {
    id_vec <- unique(df[[id_var]])
    id_list <- split(
      id_vec,
      rep(1:ceiling(length(id_vec) / max_obs_per_plot),
        each = max_obs_per_plot,
        length.out = length(id_vec)
      )
    )

    df_list <- list()
    plot_list <- list()

    for (i in seq_along(id_list)) {
      df_list[[i]] <- df[df[[id_var]] %in% id_list[[i]], ]

      plots <- h_g_ipp(
        df = df_list[[i]],
        xvar = xvar,
        yvar = yvar,
        xlab = xlab,
        ylab = ylab,
        id_var = id_var,
        title = title,
        subtitle = subtitle,
        caption = caption,
        add_baseline_hline = add_baseline_hline,
        yvar_baseline = yvar_baseline,
        ggtheme = ggtheme,
        col = col
      )

      plot_list[[i]] <- plots
    }
    return(plot_list)
  } else {
    ind_df <- split(df, df[[id_var]])
    plot_list <- lapply(
      ind_df,
      function(x) {
        h_g_ipp(
          df = x,
          xvar = xvar,
          yvar = yvar,
          xlab = xlab,
          ylab = ylab,
          id_var = id_var,
          title = title,
          subtitle = subtitle,
          caption = caption,
          add_baseline_hline = add_baseline_hline,
          yvar_baseline = yvar_baseline,
          ggtheme = ggtheme,
          col = col
        )
      }
    )

    return(plot_list)
  }
}

#' Pairwise CoxPH model
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Summarize p-value, HR and CIs from stratified or unstratified CoxPH model.
#'
#' @inheritParams argument_convention
#' @inheritParams s_surv_time
#' @param strat (`character` or `NULL`)\cr variable names indicating stratification factors.
#' @param control (`list`)\cr parameters for comparison details, specified by using the helper function
#'   [control_coxph()]. Some possible parameter options are:
#'   * `pval_method` (`string`)\cr p-value method for testing hazard ratio = 1. Default method is "log-rank" which
#'     comes from [survival::survdiff()], can also be set to "wald" or "likelihood" (from [survival::coxph()]).
#'   * `ties` (`string`)\cr specifying the method for tie handling. Default is "efron",
#'     can also be set to "breslow" or "exact". See more in [survival::coxph()]
#'   * `conf_level` (`proportion`)\cr confidence level of the interval for HR.
#'
#' @importFrom stats pchisq
#' @name survival_coxph_pairwise
NULL

#' @describeIn survival_coxph_pairwise Statistics Function which analyzes HR, CIs of HR and p-value with coxph model.
#'
#' @return The statistics are:
#' \describe{
#'   \item{pvalue}{p-value to test HR = 1.}
#'   \item{hr}{hazard ratio.}
#'   \item{hr_ci}{confidence interval for hazard ratio.}
#'   \item{n_tot}{total number of observations.}
#'   \item{n_tot_events}{total number of events.}
#' }
#'
#' @examples
#' library(dplyr)
#'
#' adtte_f <- tern_ex_adtte %>%
#'   filter(PARAMCD == "OS") %>%
#'   mutate(is_event = CNSR == 0)
#' df <- adtte_f %>%
#'   filter(ARMCD == "ARM A")
#' df_ref_group <- adtte_f %>%
#'   filter(ARMCD == "ARM B")
#'
#' # Internal function - s_coxph_pairwise
#' \dontrun{
#' s_coxph_pairwise(df, df_ref_group, .in_ref_col = FALSE, .var = "AVAL", is_event = "is_event")
#' }
#'
#' @keywords internal
s_coxph_pairwise <- function(df,
                             .ref_group,
                             .in_ref_col,
                             .var,
                             is_event,
                             strat = NULL,
                             control = control_coxph()) {
  checkmate::assert_string(.var)
  checkmate::assert_numeric(df[[.var]])
  checkmate::assert_logical(df[[is_event]])
  assert_df_with_variables(df, list(tte = .var, is_event = is_event))
  pval_method <- control$pval_method
  ties <- control$ties
  conf_level <- control$conf_level

  if (.in_ref_col) {
    return(
      list(
        pvalue = formatters::with_label("", paste0("p-value (", pval_method, ")")),
        hr = formatters::with_label("", "Hazard Ratio"),
        hr_ci = formatters::with_label("", f_conf_level(conf_level)),
        n_tot = formatters::with_label("", "Total n"),
        n_tot_events = formatters::with_label("", "Total events")
      )
    )
  }
  data <- rbind(.ref_group, df)
  group <- factor(rep(c("ref", "x"), c(nrow(.ref_group), nrow(df))), levels = c("ref", "x"))

  df_cox <- data.frame(
    tte = data[[.var]],
    is_event = data[[is_event]],
    arm = group
  )
  if (is.null(strat)) {
    formula_cox <- survival::Surv(tte, is_event) ~ arm
  } else {
    formula_cox <- stats::as.formula(
      paste0(
        "survival::Surv(tte, is_event) ~ arm + strata(",
        paste(strat, collapse = ","),
        ")"
      )
    )
    df_cox <- cbind(df_cox, data[strat])
  }
  cox_fit <- survival::coxph(
    formula = formula_cox,
    data = df_cox,
    ties = ties
  )
  sum_cox <- summary(cox_fit, conf.int = conf_level, extend = TRUE)
  orginal_survdiff <- survival::survdiff(
    formula_cox,
    data = df_cox
  )
  log_rank_pvalue <- 1 - pchisq(orginal_survdiff$chisq, length(orginal_survdiff$n) - 1)

  pval <- switch(pval_method,
    "wald" = sum_cox$waldtest["pvalue"],
    "log-rank" = log_rank_pvalue, # pvalue from original log-rank test survival::survdiff()
    "likelihood" = sum_cox$logtest["pvalue"]
  )
  list(
    pvalue = formatters::with_label(unname(pval), paste0("p-value (", pval_method, ")")),
    hr = formatters::with_label(sum_cox$conf.int[1, 1], "Hazard Ratio"),
    hr_ci = formatters::with_label(unname(sum_cox$conf.int[1, 3:4]), f_conf_level(conf_level)),
    n_tot = formatters::with_label(sum_cox$n, "Total n"),
    n_tot_events = formatters::with_label(sum_cox$nevent, "Total events")
  )
}

#' @describeIn survival_coxph_pairwise Formatted Analysis function which can be further customized by calling
#'   [rtables::make_afun()] on it. It is used as `afun` in [rtables::analyze()].
#'
#' @examples
#' # Internal function - a_coxph_pairwise
#' \dontrun{
#' a_coxph_pairwise(df, df_ref_group, .in_ref_col = FALSE, .var = "AVAL", is_event = "is_event")
#' }
#'
#' @keywords internal
a_coxph_pairwise <- make_afun(
  s_coxph_pairwise,
  .indent_mods = c(pvalue = 0L, hr = 0L, hr_ci = 1L, n_tot = 0L, n_tot_events = 0L),
  .formats = c(
    pvalue = "x.xxxx | (<0.0001)",
    hr = "xx.xx",
    hr_ci = "(xx.xx, xx.xx)",
    n_tot = "xx.xx",
    n_tot_events = "xx.xx"
  )
)


#' @describeIn survival_coxph_pairwise Analyze Function which adds the pairwise coxph analysis
#'   to the input layout. Note that additional formatting arguments can be used here.
#' @export
#'
#' @examples
#' basic_table() %>%
#'   split_cols_by(var = "ARMCD", ref_group = "ARM A") %>%
#'   add_colcounts() %>%
#'   coxph_pairwise(
#'     vars = "AVAL",
#'     is_event = "is_event",
#'     var_labels = "Unstratified Analysis"
#'   ) %>%
#'   build_table(df = adtte_f)
#'
#' basic_table() %>%
#'   split_cols_by(var = "ARMCD", ref_group = "ARM A") %>%
#'   add_colcounts() %>%
#'   coxph_pairwise(
#'     vars = "AVAL",
#'     is_event = "is_event",
#'     var_labels = "Stratified Analysis",
#'     strat = "SEX",
#'     control = control_coxph(pval_method = "wald")
#'   ) %>%
#'   build_table(df = adtte_f)
coxph_pairwise <- function(lyt,
                           vars,
                           ...,
                           var_labels = "CoxPH",
                           show_labels = "visible",
                           table_names = vars,
                           .stats = c("pvalue", "hr", "hr_ci"),
                           .formats = NULL,
                           .labels = NULL,
                           .indent_mods = NULL) {
  afun <- make_afun(
    a_coxph_pairwise,
    .stats = .stats,
    .formats = .formats,
    .labels = .labels,
    .indent_mods = .indent_mods
  )
  analyze(
    lyt,
    vars,
    var_labels = var_labels,
    show_labels = show_labels,
    table_names = table_names,
    afun = afun,
    extra_args = list(...)
  )
}

#' Occurrence Counts
#'
#' Functions for analyzing frequencies and fractions of occurrences for patients with occurrence
#' data. Primary analysis variables are the dictionary terms. All occurrences are counted for total
#' counts. Multiple occurrences within patient at the lowest term level displayed in the table are
#' counted only once. Note that by default occurrences which don't appear in a given row split
#' are dropped from the table and the occurrences in the table are sorted alphabetically per row split.
#' Therefore the corresponding layout needs to use `split_fun = drop_split_levels` in the `split_rows_by`
#' calls. Use `drop = FALSE` if you would like to show all occurrences.
#'
#' @description `r lifecycle::badge("stable")`
#' @inheritParams argument_convention
#'
#' @name count_occurrences
#'
NULL

#' @describeIn count_occurrences Statistics function which counts number of patients that report an
#' occurrence.
#'
#' @param denom (`string`)\cr choice of denominator for patient proportions. Can be:
#'   - `N_col`: total number of patients in this column across rows
#'   - `n`: number of patients with any occurrences
#' @returns A list with:
#' \describe{
#'   \item{count}{list of counts with one element per occurrence.}
#'   \item{count_fraction}{list of counts and fractions with one element per occurrence.}
#'   \item{fraction}{list of numerators and denominators with one element per occurrence.}
#' }
#'
#' @examples
#' df <- data.frame(
#'   USUBJID = as.character(c(1, 1, 2, 4, 4, 4)),
#'   MHDECOD = c("MH1", "MH2", "MH1", "MH1", "MH1", "MH3")
#' )
#'
#' N_per_col <- 4L
#'
#' # Count unique occurrences per subject.
#' s_count_occurrences(
#'   df,
#'   .N_col = N_per_col,
#'   .df_row = df,
#'   .var = "MHDECOD",
#'   id = "USUBJID"
#' )
#'
#' @export
s_count_occurrences <- function(df,
                                denom = c("N_col", "n"),
                                .N_col, # nolint
                                .df_row,
                                drop = TRUE,
                                .var = "MHDECOD",
                                id = "USUBJID") {
  checkmate::assert_flag(drop)
  assert_df_with_variables(df, list(range = .var, id = id))
  checkmate::assert_count(.N_col)
  checkmate::assert_multi_class(df[[.var]], classes = c("factor", "character"))
  checkmate::assert_multi_class(df[[id]], classes = c("factor", "character"))
  denom <- match.arg(denom)

  occurrences <- if (drop) {
    # Note that we don't try to preserve original level order here since a) that would required
    # more time to look up in large original levels and b) that would fail for character input variable.
    occurrence_levels <- sort(unique(.df_row[[.var]]))
    if (length(occurrence_levels) == 0) {
      stop(
        "no empty `.df_row` input allowed when `drop = TRUE`,",
        " please use `split_fun = drop_split_levels` in the `rtables` `split_rows_by` calls"
      )
    }
    factor(df[[.var]], levels = occurrence_levels)
  } else {
    df[[.var]]
  }
  ids <- factor(df[[id]])
  dn <- switch(denom,
    n = nlevels(ids),
    N_col = .N_col
  )
  has_occurrence_per_id <- table(occurrences, ids) > 0
  n_ids_per_occurrence <- as.list(rowSums(has_occurrence_per_id))
  list(
    count = n_ids_per_occurrence,
    count_fraction = lapply(
      n_ids_per_occurrence,
      function(i, denom) {
        if (i == 0 && denom == 0) {
          c(0, 0)
        } else {
          c(i, i / denom)
        }
      },
      denom = dn
    ),
    fraction = lapply(
      n_ids_per_occurrence,
      function(i, denom) c("num" = i, "denom" = denom),
      denom = dn
    )
  )
}

#' @describeIn count_occurrences Formatted Analysis function which can be further customized by calling
#'   [rtables::make_afun()] on it. It is used as `afun` in [rtables::analyze()].
#' @export
#'
#' @examples
#' #  We need to ungroup `count_fraction` first so that the `rtables` formatting
#' # function `format_count_fraction()` can be applied correctly.
#' afun <- make_afun(a_count_occurrences, .ungroup_stats = c("count", "count_fraction", "fraction"))
#' afun(
#'   df,
#'   .N_col = N_per_col,
#'   .df_row = df,
#'   .var = "MHDECOD",
#'   id = "USUBJID"
#' )
a_count_occurrences <- make_afun(
  s_count_occurrences,
  .formats = c(count = "xx", count_fraction = format_count_fraction_fixed_dp, fraction = format_fraction_fixed_dp)
)

#' @describeIn count_occurrences Analyze Function that counts occurrences as part of `rtables` layouts.
#'
#' @export
#'
#' @examples
#'
#' library(dplyr)
#' df <- data.frame(
#'   USUBJID = as.character(c(
#'     1, 1, 2, 4, 4, 4,
#'     6, 6, 6, 7, 7, 8
#'   )),
#'   MHDECOD = c(
#'     "MH1", "MH2", "MH1", "MH1", "MH1", "MH3",
#'     "MH2", "MH2", "MH3", "MH1", "MH2", "MH4"
#'   ),
#'   ARM = rep(c("A", "B"), each = 6)
#' )
#' df_adsl <- df %>%
#'   select(USUBJID, ARM) %>%
#'   unique()
#'
#' # Create table layout
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   add_colcounts() %>%
#'   count_occurrences(vars = "MHDECOD", .stats = c("count_fraction"))
#'
#' # Apply table layout to data and produce `rtable` object
#' lyt %>%
#'   build_table(df, alt_counts_df = df_adsl) %>%
#'   prune_table()
count_occurrences <- function(lyt,
                              vars,
                              var_labels = vars,
                              show_labels = "hidden",
                              ...,
                              table_names = vars,
                              .stats = "count_fraction",
                              .formats = NULL,
                              .labels = NULL,
                              .indent_mods = NULL) {
  afun <- make_afun(
    a_count_occurrences,
    .stats = .stats,
    .formats = .formats,
    .labels = .labels,
    .indent_mods = .indent_mods,
    .ungroup_stats = .stats
  )

  analyze(
    lyt = lyt,
    vars = vars,
    afun = afun,
    var_labels = var_labels,
    show_labels = show_labels,
    table_names = table_names,
    extra_args = list(...)
  )
}

#' Counting Specific Values
#'
#' @description `r lifecycle::badge("stable")`
#'
#' We can count the occurrence of specific values in a variable of interest.
#'
#' @name count_values_funs
#'
NULL

#' @describeIn count_values_funs Statistics Function which is a generic function to count values.
#' @inheritParams argument_convention
#' @inheritParams s_summary.logical
#' @param values (`character`)\cr specific values that should be counted.
#' @return See [s_summary.logical()] for the returned statistics, as this is used inside.
#'
#' @export
#'
s_count_values <- function(x,
                           values,
                           na.rm = TRUE, # nolint
                           .N_col, # nolint
                           .N_row, # nolint
                           denom = c("n", "N_row", "N_col")) {
  UseMethod("s_count_values", x)
}

#' @describeIn count_values_funs Method for `character` vectors `x`.
#' @method s_count_values character
#'
#' @export
#'
#' @examples
#' # `s_count_values.character`
#' s_count_values(x = c("a", "b", "a"), values = "a")
#' s_count_values(x = c("a", "b", "a", NA, NA), values = "b", na.rm = FALSE)
s_count_values.character <- function(x,
                                     values = "Y",
                                     na.rm = TRUE, # nolint
                                     ...) {
  checkmate::assert_character(values)

  if (na.rm) {
    x <- x[!is.na(x)]
  }

  is_in_values <- x %in% values

  s_summary(is_in_values, ...)
}

#' @describeIn count_values_funs method for `factor` vectors `x`. This checks whether `values` are all
#'   included in the levels of `x` and fails otherwise. It then proceeds by converting to `character`
#'   and calling `s_count_values.character`.
#' @method s_count_values factor
#'
#' @export
#'
#' @examples
#' # `s_count_values.factor`
#' s_count_values(x = factor(c("a", "b", "a")), values = "a")
s_count_values.factor <- function(x,
                                  values = "Y",
                                  ...) {
  s_count_values(as.character(x), values = as.character(values), ...)
}

#' @describeIn count_values_funs method for `logical` vectors `x`.
#' @method s_count_values logical
#'
#' @export
#'
#' @examples
#' # `s_count_values.logical`
#' s_count_values(x = c(TRUE, FALSE, TRUE))
s_count_values.logical <- function(x, values = TRUE, ...) {
  checkmate::assert_logical(values)
  s_count_values(as.character(x), values = as.character(values), ...)
}


#' @describeIn count_values_funs Formatted Analysis function which can be further customized by calling
#'   [rtables::make_afun()] on it. It is used as `afun` in [rtables::analyze()].
#' @export
#'
#' @examples
#' # `a_count_values`
#' a_count_values(x = factor(c("a", "b", "a")), values = "a", .N_col = 10, .N_row = 10)
a_count_values <- make_afun(
  s_count_values,
  .formats = c(count_fraction = "xx (xx.xx%)", count = "xx")
)

#' @describeIn count_values_funs Analyze Function which adds the counting analysis to
#'   the input layout. Note that additional formatting arguments can be used
#'   here.
#' @inheritParams argument_convention
#'
#' @note Variable labels are shown when there is more than one element in `vars`, otherwise they
#' are hidden.
#'
#' @export
#'
#' @examples
#' # `count_values`
#' basic_table() %>%
#'   count_values("Species", values = "setosa") %>%
#'   build_table(iris)
count_values <- function(lyt,
                         vars,
                         values,
                         ...,
                         table_names = vars,
                         .stats = "count_fraction",
                         .formats = NULL,
                         .labels = c(count_fraction = paste(values, collapse = ", ")),
                         .indent_mods = NULL) {
  afun <- make_afun(
    a_count_values,
    .stats = .stats,
    .formats = .formats,
    .labels = .labels,
    .indent_mods = .indent_mods
  )
  analyze(
    lyt,
    vars,
    afun = afun,
    extra_args = c(list(values = values), list(...)),
    show_labels = ifelse(length(vars) > 1, "visible", "hidden"),
    table_names = table_names
  )
}

#' Helper Function to create a map dataframe that can be used in `trim_levels_to_map` split function.
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Helper Function to create a map dataframe from the input dataset, which can be used as an argument in the
#' `trim_levels_to_map` split function. Based on different method, the map is constructed differently.
#'
#' @inheritParams argument_convention
#' @param abnormal (named `list`)\cr identifying the abnormal range level(s) in `df`. Based on the levels of abnormality
#' of the input dataset, it can be something like `list(Low = "LOW LOW", High = "HIGH HIGH")` or
#' `abnormal = list(Low = "LOW", High = "HIGH"))`
#' @param method (`string`)\cr indicates how the returned map will be constructed. Can be either `"default"` or
#' `"range"`.
#' If method is `"default"`, the returned map will only have the abnormal directions that are observed in the `df`, and
#' records with all normal values will be excluded to avoid error in creating layout.
#' If method is `"range"`, the returned map will be based on the rule that at least one observation with low range > 0
#' for low direction and at least one observation with high range is not missing for high direction.
#' @export
#'
#' @examples
#' adlb <- df_explicit_na(tern_ex_adlb)
#'
#' h_map_for_count_abnormal(
#'   df = adlb,
#'   variables = list(anl = "ANRIND", split_rows = c("LBCAT", "PARAM")),
#'   abnormal = list(low = c("LOW"), high = c("HIGH")),
#'   method = "default",
#'   na_level = "<Missing>"
#' )
#'
#' df <- data.frame(
#'   USUBJID = c(rep("1", 4), rep("2", 4), rep("3", 4)),
#'   AVISIT = c(
#'     rep("WEEK 1", 2),
#'     rep("WEEK 2", 2),
#'     rep("WEEK 1", 2),
#'     rep("WEEK 2", 2),
#'     rep("WEEK 1", 2),
#'     rep("WEEK 2", 2)
#'   ),
#'   PARAM = rep(c("ALT", "CPR"), 6),
#'   ANRIND = c(
#'     "NORMAL", "NORMAL", "LOW",
#'     "HIGH", "LOW", "LOW", "HIGH", "HIGH", rep("NORMAL", 4)
#'   ),
#'   ANRLO = rep(5, 12),
#'   ANRHI = rep(20, 12)
#' )
#' df$ANRIND <- factor(df$ANRIND, levels = c("LOW", "HIGH", "NORMAL"))
#' h_map_for_count_abnormal(
#'   df = df,
#'   variables = list(
#'     anl = "ANRIND",
#'     split_rows = c("PARAM"),
#'     range_low = "ANRLO",
#'     range_high = "ANRHI"
#'   ),
#'   abnormal = list(low = c("LOW"), high = c("HIGH")),
#'   method = "range",
#'   na_level = "<Missing>"
#' )
h_map_for_count_abnormal <- function(df,
                                     variables = list(
                                       anl = "ANRIND",
                                       split_rows = c("PARAM"),
                                       range_low = "ANRLO",
                                       range_high = "ANRHI"
                                     ),
                                     abnormal = list(low = c("LOW", "LOW LOW"), high = c("HIGH", "HIGH HIGH")),
                                     method = c("default", "range"),
                                     na_level = "<Missing>") {
  method <- match.arg(method)
  checkmate::assert_subset(c("anl", "split_rows"), names(variables))
  checkmate::assert_false(anyNA(df[variables$split_rows]))
  assert_df_with_variables(df,
    variables = list(anl = variables$anl, split_rows = variables$split_rows),
    na_level = na_level
  )
  assert_df_with_factors(df, list(val = variables$anl))
  assert_valid_factor(df[[variables$anl]], any.missing = FALSE)
  assert_list_of_variables(variables)
  checkmate::assert_list(abnormal, types = "character", len = 2)

  # Drop usued levels from df as they are not supposed to be in the final map
  df <- droplevels(df)

  normal_value <- setdiff(levels(df[[variables$anl]]), unlist(abnormal))

  # Based on the understanding of clinical data, there should only be one level of normal which is "NORMAL"
  checkmate::assert_vector(normal_value, len = 1)

  # Default method will only have what is observed in the df, and records with all normal values will be excluded to
  # avoid error in layout building.
  if (method == "default") {
    df_abnormal <- subset(df, df[[variables$anl]] %in% unlist(abnormal))
    map <- unique(df_abnormal[c(variables$split_rows, variables$anl)])
    map_normal <- unique(subset(map, select = variables$split_rows))
    map_normal[[variables$anl]] <- normal_value
    map <- rbind(map, map_normal)
  } else if (method == "range") {
    # range method follows the rule that at least one observation with ANRLO > 0 for low
    # direction and at least one observation with ANRHI is not missing for high direction.
    checkmate::assert_subset(c("range_low", "range_high"), names(variables))
    checkmate::assert_subset(c("LOW", "HIGH"), toupper(names(abnormal)))

    assert_df_with_variables(df,
      variables = list(
        range_low = variables$range_low,
        range_high = variables$range_high
      )
    )

    # Define low direction of map
    df_low <- subset(df, df[[variables$range_low]] > 0)
    map_low <- unique(df_low[variables$split_rows])
    low_levels <- unname(unlist(abnormal[toupper(names(abnormal)) == "LOW"]))
    low_levels_df <- as.data.frame(low_levels)
    colnames(low_levels_df) <- variables$anl
    low_levels_df <- do.call("rbind", replicate(nrow(map_low), low_levels_df, simplify = FALSE))
    rownames(map_low) <- NULL # Just to avoid strange row index in case upstream functions changed
    map_low <- map_low[rep(seq_len(nrow(map_low)), each = length(low_levels)), , drop = FALSE] # nolint
    map_low <- cbind(map_low, low_levels_df)

    # Define high direction of map
    df_high <- subset(df, df[[variables$range_high]] != na_level | !is.na(df[[variables$range_high]]))
    map_high <- unique(df_high[variables$split_rows])
    high_levels <- unname(unlist(abnormal[toupper(names(abnormal)) == "HIGH"]))
    high_levels_df <- as.data.frame(high_levels)
    colnames(high_levels_df) <- variables$anl
    high_levels_df <- do.call("rbind", replicate(nrow(map_high), high_levels_df, simplify = FALSE))
    rownames(map_high) <- NULL
    map_high <- map_high[rep(seq_len(nrow(map_high)), each = length(high_levels)), , drop = FALSE] # nolint
    map_high <- cbind(map_high, high_levels_df)

    # Define normal of map
    map_normal <- unique(rbind(map_low, map_high)[variables$split_rows])
    map_normal[variables$anl] <- normal_value

    map <- rbind(map_low, map_high, map_normal)
  }

  # map should be all characters
  map <- data.frame(lapply(map, as.character), stringsAsFactors = FALSE)

  # sort the map final output by split_rows variables
  for (i in rev(seq_len(length(variables$split_rows)))) {
    map <- map[order(map[[i]]), ]
  }
  map
}

#' Helper Function for Tabulation of a Single Biomarker Result
#'
#' @description`r lifecycle::badge("stable")`
#'
#' This is used by [h_tab_surv_one_biomarker()] and [h_tab_rsp_one_biomarker()],
#' please see there for examples.
#'
#' @param df (`data.frame`)\cr results for a single biomarker.
#' @param afuns (named `list` of `function`)\cr analysis functions.
#' @param colvars (`list` with `vars` and `labels`)\cr variables to tabulate and their labels.
#'
#' @return The `rtables` table object.
#'
#' @export
h_tab_one_biomarker <- function(df,
                                afuns,
                                colvars) {
  lyt <- basic_table()

  # Row split by row type - only keep the content rows here.
  lyt <- split_rows_by(
    lyt = lyt,
    var = "row_type",
    split_fun = keep_split_levels("content"),
    nested = FALSE
  )

  # Summarize rows with all patients.
  lyt <- summarize_row_groups(
    lyt = lyt,
    var = "var_label",
    cfun = afuns
  )

  # Split cols by the multiple variables to populate into columns.
  lyt <- split_cols_by_multivar(
    lyt = lyt,
    vars = colvars$vars,
    varlabels = colvars$labels
  )

  # If there is any subgroup variables, we extend the layout accordingly.
  if ("analysis" %in% df$row_type) {
    # Now only continue with the subgroup rows.
    lyt <- split_rows_by(
      lyt = lyt,
      var = "row_type",
      split_fun = keep_split_levels("analysis"),
      nested = FALSE,
      child_labels = "hidden"
    )

    # Split by the subgroup variable.
    lyt <- split_rows_by(
      lyt = lyt,
      var = "var",
      labels_var = "var_label",
      nested = TRUE,
      child_labels = "visible"
    )

    # Then analyze colvars for each subgroup.
    lyt <- summarize_row_groups(
      lyt = lyt,
      cfun = afuns,
      var = "subgroup"
    )
  }
  build_table(lyt, df = df)
}

#' Occurrence Table Sorting
#'
#' Functions to score occurrence table subtables and rows which can be used in the
#' sorting of occurrence tables.
#'
#' @name score_occurrences
#'
NULL

#' @description `r lifecycle::badge("stable")`
#' @describeIn score_occurrences Scoring function which sums the counts across all
#'   columns. It will fail if anything else but counts are used.
#' @inheritParams rtables_access
#'
#' @return [score_occurrences()] returns the sum of counts across all columns of a table row.
#'
#' @seealso [h_row_first_values()]
#'
#' @examples
#' lyt <- basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   add_colcounts() %>%
#'   analyze_num_patients(
#'     vars = "USUBJID",
#'     .stats = c("unique"),
#'     .labels = c("Total number of patients with at least one event")
#'   ) %>%
#'   split_rows_by("AEBODSYS", child_labels = "visible", nested = FALSE) %>%
#'   summarize_num_patients(
#'     var = "USUBJID",
#'     .stats = c("unique", "nonunique"),
#'     .labels = c(
#'       "Total number of patients with at least one event",
#'       "Total number of events"
#'     )
#'   ) %>%
#'   count_occurrences(vars = "AEDECOD")
#'
#' tbl <- build_table(lyt, tern_ex_adae, alt_counts_df = tern_ex_adsl) %>%
#'   prune_table()
#'
#' tbl_sorted <- tbl %>%
#'   sort_at_path(path = c("AEBODSYS", "*", "AEDECOD"), scorefun = score_occurrences)
#'
#' tbl_sorted
#'
#' @export
score_occurrences <- function(table_row) {
  row_counts <- h_row_counts(table_row)
  sum(row_counts)
}

#' @describeIn score_occurrences Scoring functions can be produced by this constructor to only include
#'   specific columns in the scoring. See [h_row_counts()] for further information.
#' @inheritParams has_count_in_cols
#'
#' @return [score_occurrences_cols()] returns a function that sums counts across all specified columns
#'   of a table row.
#'
#' @seealso [h_row_counts()]
#'
#' @examples
#' score_cols_a_and_b <- score_occurrences_cols(col_names = c("A: Drug X", "B: Placebo"))
#'
#' # Note that this here just sorts the AEDECOD inside the AEBODSYS. The AEBODSYS are not sorted.
#' # That would require a second pass of `sort_at_path`.
#' tbl_sorted <- tbl %>%
#'   sort_at_path(path = c("AEBODSYS", "*", "AEDECOD"), scorefun = score_cols_a_and_b)
#'
#' tbl_sorted
#'
#' @export
score_occurrences_cols <- function(...) {
  function(table_row) {
    row_counts <- h_row_counts(table_row, ...)
    sum(row_counts)
  }
}

#' @describeIn score_occurrences Scoring functions produced by this constructor can be used on
#'   subtables: They sum up all specified column counts in the subtable. This is useful when
#'   there is no available content row summing up these counts.
#' @return [score_occurrences_subtable()] returns a function that sums counts in each subtable
#'   across all specified columns.
#'
#' @export
#'
#' @examples
#' score_subtable_all <- score_occurrences_subtable(col_names = names(tbl))
#'
#' # Note that this code just sorts the AEBODSYS, not the AEDECOD within AEBODSYS. That
#' # would require a second pass of `sort_at_path`.
#' tbl_sorted <- tbl %>%
#'   sort_at_path(path = c("AEBODSYS"), scorefun = score_subtable_all, decreasing = FALSE)
#'
#' tbl_sorted
score_occurrences_subtable <- function(...) {
  score_table_row <- score_occurrences_cols(...)
  function(table_tree) {
    table_rows <- collect_leaves(table_tree)
    counts <- vapply(table_rows, score_table_row, numeric(1))
    sum(counts)
  }
}

#' @describeIn score_occurrences Produce score function for sorting table by summing the first content row in
#'   specified columns. Note that this is extending [rtables::cont_n_onecol()] and [rtables::cont_n_allcols()].
#' @export
#'
score_occurrences_cont_cols <- function(...) {
  score_table_row <- score_occurrences_cols(...)
  function(table_tree) {
    if (inherits(table_tree, "ContentRow")) {
      return(NA)
    }
    content_row <- h_content_first_row(table_tree)
    score_table_row(content_row)
  }
}

#' Control function for incidence rate
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This is an auxiliary function for controlling arguments for the incidence rate, used
#' internally to specify details in `s_incidence_rate()`.
#'
#' @inheritParams argument_convention
#' @param time_unit_input (`string`)\cr `day`, `month`, or `year` (default)
#'   indicating time unit for data input.
#' @param time_unit_output (`numeric`)\cr time unit for desired output (in person-years).
#' @param conf_type (`string`)\cr `normal` (default), `normal_log`, `exact`, or `byar`
#'   for confidence interval type.
#' @return A list of components with the same name as the arguments.
#' @export
#' @examples
#' control_incidence_rate(0.9, "exact", "month", 100)
#' @seealso [incidence_rate]
control_incidence_rate <- function(conf_level = 0.95,
                                   conf_type = c("normal", "normal_log", "exact", "byar"),
                                   time_unit_input = c("year", "day", "week", "month"),
                                   time_unit_output = 1) {
  conf_type <- match.arg(conf_type)
  time_unit_input <- match.arg(time_unit_input)
  checkmate::assert_number(time_unit_output)
  assert_proportion_value(conf_level)

  list(
    conf_level = conf_level,
    conf_type = conf_type,
    time_unit_input = time_unit_input,
    time_unit_output = time_unit_output
  )
}

#' Counting Missed Doses
#'
#' @description `r lifecycle::badge("stable")`
#'
#' These are specific functions to count patients with missed doses. The difference to [count_cumulative()] is
#' mainly the special labels.
#'
#' @seealso Relevant description function [d_count_missed_doses()].
#'
#' @name count_missed_doses
#'
NULL

#' @describeIn count_missed_doses Statistics function to count non-missing values.
#' @return [s_count_nonmissing()] returns the statistic `n` which is the count of non-missing values in `x`.
#' @examples
#' set.seed(1)
#' x <- c(sample(1:10, 10), NA)
#'
#' # Internal function - s_count_nonmissing
#' \dontrun{
#' s_count_nonmissing(x)
#' }
#'
#' @keywords internal
s_count_nonmissing <- function(x) {
  list(n = n_available(x))
}

#' Description Function that Calculates Labels for [s_count_missed_doses()].
#'
#' @description `r lifecycle::badge("stable")`
#'
#' @inheritParams s_count_missed_doses
#' @return [d_count_missed_doses()] returns a named `character` vector with the labels.
#' @seealso [s_count_missed_doses()]
#'
#' @export
d_count_missed_doses <- function(thresholds) {
  paste0("At least ", thresholds, " missed dose", ifelse(thresholds > 1, "s", ""))
}

#' @describeIn count_missed_doses Statistics function to count patients with missed doses when `x`
#'   is the vector of number of missed doses with one value for each patient.
#' @inheritParams argument_convention
#' @param thresholds (vector of `count`)\cr number of missed doses the patients at least had.
#' @return [s_count_missed_doses()] returns the statistics `n` and
#'  `count_fraction` with one element for each threshold.
#'
#' @examples
#' # Internal function - s_count_missed_doses
#' \dontrun{
#' s_count_missed_doses(x = c(0, 1, 0, 2, 3, 4, 0, 2), thresholds = c(2, 5), .N_col = 10)
#' }
#'
#' @keywords internal
s_count_missed_doses <- function(x,
                                 thresholds,
                                 .N_col) { # nolint
  stat <- s_count_cumulative(
    x = x,
    thresholds = thresholds,
    lower_tail = FALSE,
    include_eq = TRUE,
    .N_col = .N_col
  )
  labels <- d_count_missed_doses(thresholds)
  for (i in seq_along(stat$count_fraction)) {
    stat$count_fraction[[i]] <- formatters::with_label(stat$count_fraction[[i]], label = labels[i])
  }
  n_stat <- s_count_nonmissing(x)
  c(n_stat, stat)
}

#' @describeIn count_missed_doses Formatted Analysis function to count non-missing values.
#'
#' @examples
#' # Internal function - a_count_missed_doses
#' \dontrun{
#' #  We need to ungroup `count_fraction` first so that the `rtables` formatting
#' # function `format_count_fraction()` can be applied correctly.
#' afun <- make_afun(a_count_missed_doses, .ungroup_stats = "count_fraction")
#' afun(x = c(0, 1, 0, 2, 3, 4, 0, 2), thresholds = c(2, 5), .N_col = 10)
#' }
#'
#' @keywords internal
a_count_missed_doses <- make_afun(
  s_count_missed_doses,
  .formats = c(n = "xx", count_fraction = format_count_fraction)
)

#' @describeIn count_missed_doses Layout creating function which can be be used for creating
#'   summary tables for summarizing missed doses given user-specified `thresholds`. This is
#'   an additional layer on top of `count_cumulative` specifically for missed doses.
#' @inheritParams argument_convention
#' @inheritParams s_count_cumulative
#' @export
#' @examples
#' library(dplyr)
#'
#' anl <- tern_ex_adsl %>%
#'   distinct(STUDYID, USUBJID, ARM) %>%
#'   mutate(
#'     PARAMCD = "TNDOSMIS",
#'     PARAM = "Total number of missed doses during study",
#'     AVAL = sample(0:20, size = nrow(tern_ex_adsl), replace = TRUE),
#'     AVALC = ""
#'   )
#'
#' basic_table() %>%
#'   split_cols_by("ARM") %>%
#'   add_colcounts() %>%
#'   count_missed_doses("AVAL", thresholds = c(1, 5, 10, 15), var_labels = "Missed Doses") %>%
#'   build_table(anl, alt_counts_df = tern_ex_adsl)
count_missed_doses <- function(lyt,
                               vars,
                               var_labels = vars,
                               show_labels = "visible",
                               ...,
                               table_names = vars,
                               .stats = NULL,
                               .formats = NULL,
                               .labels = NULL,
                               .indent_mods = NULL) {
  afun <- make_afun(
    a_count_missed_doses,
    .stats = .stats,
    .formats = .formats,
    .labels = .labels,
    .indent_mods = .indent_mods,
    .ungroup_stats = "count_fraction"
  )
  analyze(
    lyt = lyt,
    vars = vars,
    afun = afun,
    var_labels = var_labels,
    table_names = table_names,
    show_labels = show_labels,
    extra_args = list(...)
  )
}

#' Control Function for `CoxPH` Model
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This is an auxiliary function for controlling arguments for `CoxPH` model, typically used internally to specify
#' details of `CoxPH` model for [s_coxph_pairwise]. `conf_level` refers to Hazard Ratio estimation.
#'
#' @param pval_method (`string`)\cr p-value method for testing hazard ratio = 1.
#'   Default method is \code{"log-rank"}, can also be set to \code{"wald"} or \code{"likelihood"}.
#' @param ties 	(`string`)\cr specifying the method for tie handling. Default is \code{"efron"},
#'   can also be set to \code{"breslow"} or \code{"exact"}. see more in [survival::coxph()]
#' @inheritParams argument_convention
#' @return A list of components with the same names as the arguments
#'
#' @export
control_coxph <- function(pval_method = c("log-rank", "wald", "likelihood"),
                          ties = c("efron", "breslow", "exact"),
                          conf_level = 0.95) {
  pval_method <- match.arg(pval_method)
  ties <- match.arg(ties)
  assert_proportion_value(conf_level)

  list(pval_method = pval_method, ties = ties, conf_level = conf_level)
}

#' Control Function for `survfit` Model for Survival Time
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This is an auxiliary function for controlling arguments for `survfit` model, typically used internally to specify
#' details of `survfit` model for [s_surv_time]. `conf_level` refers to survival time estimation.
#'
#' @inheritParams argument_convention
#' @param conf_type (`string`)\cr confidence interval type. Options are "plain" (default), "log", "log-log",
#'   see more in [survival::survfit()]. Note option "none" is no longer supported.
#' @param quantiles (`numeric`)\cr of length two to specify the quantiles of survival time.
#' @return A list of components with the same names as the arguments
#'
#' @export
control_surv_time <- function(conf_level = 0.95,
                              conf_type = c("plain", "log", "log-log"),
                              quantiles = c(0.25, 0.75)) {
  conf_type <- match.arg(conf_type)
  checkmate::assert_numeric(quantiles, lower = 0, upper = 1, len = 2, unique = TRUE, sorted = TRUE)
  nullo <- lapply(quantiles, assert_proportion_value)
  assert_proportion_value(conf_level)
  list(conf_level = conf_level, conf_type = conf_type, quantiles = quantiles)
}

#' Control Function for `survfit` Model for Patient's Survival Rate at time point
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This is an auxiliary function for controlling arguments for `survfit` model, typically used internally to specify
#' details of `survfit` model for [s_surv_timepoint]. `conf_level` refers to patient risk estimation at a time point.
#'
#' @inheritParams argument_convention
#' @inheritParams control_surv_time
#' @return A list of components with the same names as the arguments
#'
#' @export
control_surv_timepoint <- function(conf_level = 0.95,
                                   conf_type = c("plain", "log", "log-log")) {
  conf_type <- match.arg(conf_type)
  assert_proportion_value(conf_level)
  list(
    conf_level = conf_level,
    conf_type = conf_type
  )
}

#' Control Function for Logistic Regression Model Fitting
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This is an auxiliary function for controlling arguments for logistic regression models.
#' `conf_level` refers to the confidence level used for the Odds Ratio CIs.
#'
#' @param response_definition (`string`)\cr the definition of what an event is in terms of `response`.
#'   This will be used when fitting the logistic regression model on the left hand side of the formula.
#'   Note that the evaluated expression should result in either a logical vector or a factor with 2
#'   levels. By default this is just `"response"` such that the original response variable is used
#'   and not modified further.
#' @inheritParams argument_convention
#' @return A list of components with the same names as the arguments.
#' @export
#' @examples
#' # Standard options.
#' control_logistic()
#'
#' # Modify confidence level.
#' control_logistic(conf_level = 0.9)
#'
#' # Use a different response definition.
#' control_logistic(response_definition = "I(response %in% c('CR', 'PR'))")
control_logistic <- function(response_definition = "response",
                             conf_level = 0.95) {
  checkmate::assert_true(grepl("response", response_definition))
  checkmate::assert_string(response_definition)
  assert_proportion_value(conf_level)
  list(
    response_definition = response_definition,
    conf_level = conf_level
  )
}

#' Combination Functions Class
#'
#' @description `r lifecycle::badge("stable")`
#'
#' `CombinationFunction` is an S4 class which extends standard functions. These are special functions that
#' can be combined and negated with the logical operators.
#'
#' @param e1 (`CombinationFunction`)\cr left hand side of logical operator.
#' @param e2 (`CombinationFunction`)\cr right hand side of logical operator.
#' @param x (`CombinationFunction`)\cr the function which should be negated.
#'
#' @exportClass CombinationFunction
#' @export CombinationFunction
#'
#' @aliases CombinationFunction-class
#' @name combination_function
#'
#' @examples
#' higher <- function(a) {
#'   force(a)
#'   CombinationFunction(
#'     function(x) {
#'       x > a
#'     }
#'   )
#' }
#'
#' lower <- function(b) {
#'   force(b)
#'   CombinationFunction(
#'     function(x) {
#'       x < b
#'     }
#'   )
#' }
#'
#' c1 <- higher(5)
#' c2 <- lower(10)
#' c3 <- higher(5) & lower(10)
#' c3(7)
CombinationFunction <- methods::setClass("CombinationFunction", contains = "function") # nolint

#' @describeIn combination_function Logical "AND" combination of `CombinationFunction` functions.
#'   The resulting object is of the same class, and evaluates the two argument functions. The result
#'   is then the "AND" of the two individual results.
#' @export
#'
methods::setMethod(
  "&",
  signature = c(e1 = "CombinationFunction", e2 = "CombinationFunction"),
  definition = function(e1, e2) {
    CombinationFunction(function(...) {
      e1(...) && e2(...)
    })
  }
)

#' @describeIn combination_function Logical "OR" combination of `CombinationFunction` functions.
#'   The resulting object is of the same class, and evaluates the two argument functions. The result
#'   is then the "OR" of the two individual results.
#' @export
#'
methods::setMethod(
  "|",
  signature = c(e1 = "CombinationFunction", e2 = "CombinationFunction"),
  definition = function(e1, e2) {
    CombinationFunction(function(...) {
      e1(...) || e2(...)
    })
  }
)

#' @describeIn combination_function Logical negation of `CombinationFunction` functions.
#'   The resulting object is of the same class, and evaluates the original function. The result
#'   is then the opposite of this results.
#' @export
#'
methods::setMethod(
  "!",
  signature = c(x = "CombinationFunction"),
  definition = function(x) {
    CombinationFunction(function(...) {
      !x(...)
    })
  }
)

1		#' Occurrence Table Pruning
2		#'
3		#' @description `r lifecycle::badge("stable")`
4		#'
5		#' Family of constructor and condition functions to flexibly prune occurrence tables.
6		#' The condition functions always return whether the row result is higher than the threshold.
7		#' Since they are of class [CombinationFunction()] they can be logically combined with other condition
8		#' functions.
9		#'
10		#' @note Since most table specifications are worded positively, we name our constructor and condition
11		#' functions positively, too. However, note that the result of [keep_rows()] says what
12		#' should be pruned though, to conform with the [rtables::prune_table()] interface.
13		#'
14		#' @name prune_occurrences
15		#' @examples
16		#' \dontrun{
17		#' tab <- basic_table() %>%
18		#' split_cols_by("ARM") %>%
19		#' split_rows_by("RACE") %>%
20		#' split_rows_by("STRATA1") %>%
21		#' summarize_row_groups() %>%
22		#' summarize_vars("COUNTRY", .stats = "count_fraction") %>%
23		#' build_table(DM)
24		#' }
25		#'
26		NULL
27
28		#' @describeIn prune_occurrences constructor for creating pruning functions based on
29		#' a row condition function. This removes all analysis rows (`TableRow`) that should be
30		#' pruned, i.e., don't fulfill the row condition. It removes the sub tree if there are no
31		#' children left.
32		#' @param row_condition (`CombinationFunction`)\cr condition function which works on individual
33		#' analysis rows and flags whether these should be kept in the pruned table.
34		#' @return [keep_rows()] returns a pruning function that can be used with [rtables::prune_table()]
35		#' on `[rtables::TableTree()]` objects.
36		#' @export
37		#'
38		#' @examples
39		#' \dontrun{
40		#' # `keep_rows`
41		#' is_non_empty <- !CombinationFunction(all_zero_or_na)
42		#' prune_table(tab, keep_rows(is_non_empty))
43		#' }
44		keep_rows <- function(row_condition) {
45	6x	checkmate::assert_function(row_condition)
46	6x	function(table_tree) {
47	2256x	if (inherits(table_tree, "TableRow")) {
48	1872x	return(!row_condition(table_tree))
49		}
50	384x	children <- tree_children(table_tree)
51	384x	identical(length(children), 0L)
52		}
53		}
54
55		#' @describeIn prune_occurrences constructor for creating pruning functions based on
56		#' a condition for the (first) content row in leaf tables. This removes all leaf tables where
57		#' the first content row does not fulfill the condition. It does not check individual rows.
58		#' It then proceeds recursively by removing the sub tree if there are no children left.
59		#' @param content_row_condition (`CombinationFunction`)\cr condition function which works on individual
60		#' first content rows of leaf tables and flags whether these leaf tables should be kept in the pruned table.
61		#' @return [keep_content_rows()] also returns a pruning function, the difference is that it
62		#' checks the condition on the first content row of leaf tables in the table.
63		#'
64		#' @examples
65		#' # `keep_content_rows`
66		#' # Internal function - has_count_in_cols
67		#' \dontrun{
68		#' more_than_twenty <- has_count_in_cols(atleast = 20L, col_names = names(tab))
69		#' prune_table(tab, keep_content_rows(more_than_twenty))
70		#' }
71		#'
72		#' @export
73		keep_content_rows <- function(content_row_condition) {
74	1x	checkmate::assert_function(content_row_condition)
75	1x	function(table_tree) {
76	166x	if (is_leaf_table(table_tree)) {
77	24x	content_row <- h_content_first_row(table_tree)
78	24x	return(!content_row_condition(content_row))
79		}
80	142x	if (inherits(table_tree, "DataRow")) {
81	120x	return(FALSE)
82		}
83	22x	children <- tree_children(table_tree)
84	22x	identical(length(children), 0L)
85		}
86		}
87
88		#' @describeIn prune_occurrences constructor for creating condition functions on total counts in
89		#' the specified columns.
90		#' @param atleast (`count` or `proportion`)\cr threshold which should be met in order to
91		#' keep the row.
92		#' @param ... arguments for row or column access, see [`rtables_access`]: either
93		#' `col_names` (`character`) including the names of the columns which should be used,
94		#' or alternatively `col_indices` (`integer`) giving the indices directly instead.
95		#' @return [has_count_in_cols()] returns a condition function that sums the counts in the specified
96		#' column.
97		#'
98		#' @examples
99		#' # Internal function - has_count_in_cols
100		#' \dontrun{
101		#' more_than_one <- has_count_in_cols(atleast = 1L, col_names = names(tab))
102		#' prune_table(tab, keep_rows(more_than_one))
103		#' }
104		#'
105		#' @keywords internal
106		has_count_in_cols <- function(atleast, ...) {
107	3x	checkmate::assert_count(atleast)
108	3x	CombinationFunction(function(table_row) {
109	334x	row_counts <- h_row_counts(table_row, ...)
110	334x	total_count <- sum(row_counts)
111	334x	total_count >= atleast
112		})
113		}
114
115		#' @describeIn prune_occurrences constructor for creating condition functions on any of the counts in
116		#' the specified columns satisfying a threshold.
117		#' @param atleast (`count` or `proportion`)\cr threshold which should be met in order to
118		#' keep the row.
119		#' @return [has_count_in_any_col()] returns a condition function that compares the counts in the
120		#' specified columns with the threshold.
121		#' @export
122		#'
123		#' @examples
124		#' \dontrun{
125		#' # `has_count_in_any_col`
126		#' any_more_than_one <- has_count_in_any_col(atleast = 1L, col_names = names(tab))
127		#' prune_table(tab, keep_rows(any_more_than_one))
128		#' }
129		has_count_in_any_col <- function(atleast, ...) {
130	!	checkmate::assert_count(atleast)
131	!	CombinationFunction(function(table_row) {
132	!	row_counts <- h_row_counts(table_row, ...)
133	!	any(row_counts >= atleast)
134		})
135		}
136
137		#' @describeIn prune_occurrences constructor for creating condition functions on total fraction in
138		#' the specified columns.
139		#' @return [has_fraction_in_cols()] returns a condition function that sums the counts in the
140		#' specified column, and computes the fraction by dividing by the total column counts.
141		#' @export
142		#'
143		#' @examples
144		#' \dontrun{
145		#' # `has_fraction_in_cols`
146		#' more_than_five_percent <- has_fraction_in_cols(atleast = 0.05, col_names = names(tab))
147		#' prune_table(tab, keep_rows(more_than_five_percent))
148		#' }
149		has_fraction_in_cols <- function(atleast, ...) {
150	1x	assert_proportion_value(atleast, include_boundaries = TRUE)
151	1x	CombinationFunction(function(table_row) {
152	303x	row_counts <- h_row_counts(table_row, ...)
153	303x	total_count <- sum(row_counts)
154	303x	col_counts <- h_col_counts(table_row, ...)
155	303x	total_n <- sum(col_counts)
156	303x	total_percent <- total_count / total_n
157	303x	total_percent >= atleast
158		})
159		}
160
161		#' @describeIn prune_occurrences constructor for creating condition functions on any fraction in
162		#' the specified columns.
163		#' @return [has_fraction_in_cols()] returns a condition function that looks at the fractions
164		#' in the specified columns and checks whether any of them fulfill the threshold.
165		#' @export
166		#'
167		#' @examples
168		#' \dontrun{
169		#' # `has_fraction_in_any_col`
170		#' any_atleast_five_percent <- has_fraction_in_any_col(atleast = 0.05, col_names = names(tab))
171		#' prune_table(tab, keep_rows(more_than_five_percent))
172		#' }
173		has_fraction_in_any_col <- function(atleast, ...) {
174	!	assert_proportion_value(atleast, include_boundaries = TRUE)
175	!	CombinationFunction(function(table_row) {
176	!	row_fractions <- h_row_fractions(table_row, ...)
177	!	any(row_fractions >= atleast)
178		})
179		}
180
181		#' @describeIn prune_occurrences constructor for creating condition function that checks the difference
182		#' between the fractions reported in each specified column.
183		#' @return [has_fractions_difference()] returns a condition function that extracts the fractions of each
184		#' specified column, and computes the difference of the minimum and maximum.
185		#' @export
186		#'
187		#' @examples
188		#' \dontrun{
189		#' # `has_fractions_difference`
190		#' more_than_five_percent_diff <- has_fractions_difference(atleast = 0.05, col_names = names(tab))
191		#' prune_table(tab, keep_rows(more_than_five_percent_diff))
192		#' }
193		has_fractions_difference <- function(atleast, ...) {
194	1x	assert_proportion_value(atleast, include_boundaries = TRUE)
195	1x	CombinationFunction(function(table_row) {
196	243x	fractions <- h_row_fractions(table_row, ...)
197	243x	difference <- diff(range(fractions))
198	243x	difference >= atleast
199		})
200		}
201
202		#' @describeIn prune_occurrences constructor for creating condition function that checks the difference
203		#' between the counts reported in each specified column.
204		#' @return [has_counts_difference()] returns a condition function that extracts the counts of each
205		#' specified column, and computes the difference of the minimum and maximum.
206		#'
207		#' @examples
208		#' # Internal function - has_counts_difference
209		#' \dontrun{
210		#' more_than_one_diff <- has_counts_difference(atleast = 1L, col_names = names(tab))
211		#' prune_table(tab, keep_rows(more_than_one_diff))
212		#' }
213		#'
214		#' @keywords internal
215		has_counts_difference <- function(atleast, ...) {
216	1x	checkmate::assert_count(atleast)
217	1x	CombinationFunction(function(table_row) {
218	27x	counts <- h_row_counts(table_row, ...)
219	27x	difference <- diff(range(counts))
220	27x	difference >= atleast
221		})
222		}

1		#' Occurrence Counts by Grade
2		#'
3		#' @description `r lifecycle::badge("stable")`
4		#'
5		#' Functions for analyzing frequencies and fractions of occurrences by grade for patients
6		#' with occurrence data. Multiple occurrences within one individual are counted once at the
7		#' greatest intensity/highest grade level.
8		#'
9		#' @inheritParams argument_convention
10		#' @param grade_groups (named `list` of `character`)\cr containing groupings of grades.
11		#' @param remove_single (`logical`)\cr `TRUE` to not include the elements of one-element grade groups
12		#' in the the output list; in this case only the grade groups names will be included in the output.
13		#'
14		#' @seealso Relevant helper function [h_append_grade_groups()].
15		#'
16		#' @name count_occurrences_by_grade
17		#'
18		NULL
19
20		#' Helper function for [s_count_occurrences_by_grade()]
21		#'
22		#' @description `r lifecycle::badge("stable")`
23		#'
24		#' Helper function for [s_count_occurrences_by_grade()] to insert grade groupings into list with
25		#' individual grade frequencies. The order of the final result follows the order of `grade_groups`.
26		#' The elements under any-grade group (if any), i.e. the grade group equal to `refs` will be moved to
27		#' the end. Grade groups names must be unique.
28		#'
29		#' @inheritParams count_occurrences_by_grade
30		#' @param refs (named `list` of `numeric`)\cr where each name corresponds to a reference grade level
31		#' and each entry represents a count.
32		#'
33		#' @examples
34		#' h_append_grade_groups(
35		#' list(
36		#' "Any Grade" = as.character(1:5),
37		#' "Grade 1-2" = c("1", "2"),
38		#' "Grade 3-4" = c("3", "4")
39		#' ),
40		#' list("1" = 10, "2" = 20, "3" = 30, "4" = 40, "5" = 50)
41		#' )
42		#'
43		#' h_append_grade_groups(
44		#' list(
45		#' "Any Grade" = as.character(5:1),
46		#' "Grade A" = "5",
47		#' "Grade B" = c("4", "3")
48		#' ),
49		#' list("1" = 10, "2" = 20, "3" = 30, "4" = 40, "5" = 50)
50		#' )
51		#'
52		#' h_append_grade_groups(
53		#' list(
54		#' "Any Grade" = as.character(1:5),
55		#' "Grade 1-2" = c("1", "2"),
56		#' "Grade 3-4" = c("3", "4")
57		#' ),
58		#' list("1" = 10, "2" = 5, "3" = 0)
59		#' )
60		#'
61		#' @export
62		h_append_grade_groups <- function(grade_groups, refs, remove_single = TRUE) {
63	13x	checkmate::assert_list(grade_groups)
64	13x	checkmate::assert_list(refs)
65	13x	refs_orig <- refs
66	13x	elements <- unique(unlist(grade_groups))
67
68		### compute sums in groups
69	13x	grp_sum <- lapply(grade_groups, function(i) do.call(sum, refs[i]))
70	13x	if (!checkmate::test_subset(elements, names(refs))) {
71	2x	padding_el <- setdiff(elements, names(refs))
72	2x	refs[padding_el] <- 0
73		}
74	13x	result <- c(grp_sum, refs)
75
76		### order result while keeping grade_groups's ordering
77	13x	ordr <- grade_groups
78
79		# elements of any-grade group (if any) will be moved to the end
80	13x	is_any <- sapply(grade_groups, setequal, y = names(refs))
81	13x	ordr[is_any] <- list(character(0)) # hide elements under any-grade group
82
83		# groups-elements combined sequence
84	13x	ordr <- c(lapply(names(ordr), function(g) c(g, ordr[[g]])), recursive = TRUE, use.names = FALSE)
85	13x	ordr <- ordr[!duplicated(ordr)]
86
87		# append remaining elements (if any)
88	13x	ordr <- union(ordr, unlist(grade_groups[is_any])) # from any-grade group
89	13x	ordr <- union(ordr, names(refs)) # from refs
90
91		# remove elements of single-element groups, if any
92	13x	if (remove_single) {
93	13x	is_single <- sapply(grade_groups, length) == 1L
94	13x	ordr <- setdiff(ordr, unlist(grade_groups[is_single]))
95		}
96
97		# apply the order
98	13x	result <- result[ordr]
99
100		# remove groups without any elements in the original refs
101		# note: it's OK if groups have 0 value
102	13x	keep_grp <- vapply(grade_groups, function(x, rf) {
103	37x	any(x %in% rf)
104	13x	}, rf = names(refs_orig), logical(1))
105
106	13x	keep_el <- names(result) %in% names(refs_orig) \| names(result) %in% names(keep_grp)[keep_grp]
107	13x	result <- result[keep_el]
108
109	13x	result
110		}
111
112		#' @describeIn count_occurrences_by_grade Statistics function which given occurrence data counts the
113		#' number of patients by highest grade. Returns a list of counts and fractions with one element
114		#' per grade level or grade level grouping.
115		#'
116		#' @examples
117		#' library(dplyr)
118		#' df <- data.frame(
119		#' USUBJID = as.character(c(1:6, 1)),
120		#' ARM = factor(c("A", "A", "A", "B", "B", "B", "A"), levels = c("A", "B")),
121		#' AETOXGR = factor(c(1, 2, 3, 4, 1, 2, 3), levels = c(1:5)),
122		#' AESEV = factor(
123		#' x = c("MILD", "MODERATE", "SEVERE", "MILD", "MILD", "MODERATE", "SEVERE"),
124		#' levels = c("MILD", "MODERATE", "SEVERE")
125		#' ),
126		#' stringsAsFactors = FALSE
127		#' )
128		#' df_adsl <- df %>%
129		#' select(USUBJID, ARM) %>%
130		#' unique()
131		#'
132		#' s_count_occurrences_by_grade(
133		#' df,
134		#' .N_col = 10L, # nolint
135		#' .var = "AETOXGR",
136		#' id = "USUBJID",
137		#' grade_groups = list("ANY" = levels(df$AETOXGR))
138		#' )
139		#'
140		#' @export
141		s_count_occurrences_by_grade <- function(df,
142		.var,
143		.N_col, # nolint
144		id = "USUBJID",
145		grade_groups = list(),
146		remove_single = TRUE,
147		labelstr = "") {
148	3x	assert_valid_factor(df[[.var]])
149	3x	assert_df_with_variables(df, list(grade = .var, id = id))
150
151	3x	if (nrow(df) < 1) {
152	!	grade_levels <- levels(df[[.var]])
153	!	l_count <- as.list(rep(0, length(grade_levels)))
154	!	names(l_count) <- grade_levels
155		} else {
156	3x	if (isTRUE(is.factor(df[[id]]))) {
157	!	assert_valid_factor(df[[id]], any.missing = FALSE)
158		} else {
159	3x	checkmate::assert_character(df[[id]], min.chars = 1, any.missing = FALSE)
160		}
161	3x	checkmate::assert_count(.N_col)
162
163	3x	id <- df[[id]]
164	3x	grade <- df[[.var]]
165
166	3x	if (!is.ordered(grade)) {
167	3x	grade_lbl <- obj_label(grade)
168	3x	lvls <- levels(grade)
169	3x	if (sum(grepl("^\\d+$", lvls)) %in% c(0, length(lvls))) {
170	3x	lvl_ord <- lvls
171		} else {
172	!	lvls[!grepl("^\\d+$", lvls)] <- min(as.numeric(lvls[grepl("^\\d+$", lvls)])) - 1
173	!	lvl_ord <- levels(grade)[order(as.numeric(lvls))]
174		}
175	3x	grade <- formatters::with_label(factor(grade, levels = lvl_ord, ordered = TRUE), grade_lbl)
176		}
177
178	3x	df_max <- stats::aggregate(grade ~ id, FUN = max, drop = FALSE)
179	3x	l_count <- as.list(table(df_max$grade))
180		}
181
182	3x	if (length(grade_groups) > 0) {
183	2x	l_count <- h_append_grade_groups(grade_groups, l_count, remove_single)
184		}
185
186	3x	l_count_fraction <- lapply(l_count, function(i, denom) c(i, i / denom), denom = .N_col)
187
188	3x	list(
189	3x	count_fraction = l_count_fraction
190		)
191		}
192
193		#' @describeIn count_occurrences_by_grade Formatted Analysis function which can be further customized by calling
194		#' [rtables::make_afun()] on it. It is used as `afun` in [rtables::analyze()].
195		#' @export
196		#'
197		#' @examples
198		#' # We need to ungroup `count_fraction` first so that the `rtables` formatting
199		#' # function `format_count_fraction()` can be applied correctly.
200		#' afun <- make_afun(a_count_occurrences_by_grade, .ungroup_stats = "count_fraction")
201		#' afun(
202		#' df,
203		#' .N_col = 10L, # nolint
204		#' .var = "AETOXGR",
205		#' id = "USUBJID",
206		#' grade_groups = list("ANY" = levels(df$AETOXGR))
207		#' )
208		a_count_occurrences_by_grade <- make_afun(
209		s_count_occurrences_by_grade,
210		.formats = c("count_fraction" = format_count_fraction_fixed_dp)
211		)
212
213
214		#' @describeIn count_occurrences_by_grade Layout creating function which can be used for creating tables,
215		#' which can take statistics function arguments and additional format arguments (see below).
216		#' @param var_labels (`character`)\cr labels to show in the result table.
217		#' @export
218		#' @examples
219		#'
220		#' # Layout creating function with custom format.
221		#' basic_table() %>%
222		#' split_cols_by("ARM") %>%
223		#' add_colcounts() %>%
224		#' count_occurrences_by_grade(
225		#' var = "AESEV",
226		#' .formats = c("count_fraction" = "xx.xx (xx.xx%)")
227		#' ) %>%
228		#' build_table(df, alt_counts_df = df_adsl)
229		#'
230		#' # Define additional grade groupings.
231		#' grade_groups <- list(
232		#' "-Any-" = c("1", "2", "3", "4", "5"),
233		#' "Grade 1-2" = c("1", "2"),
234		#' "Grade 3-5" = c("3", "4", "5")
235		#' )
236		#'
237		#' basic_table() %>%
238		#' split_cols_by("ARM") %>%
239		#' add_colcounts() %>%
240		#' count_occurrences_by_grade(
241		#' var = "AETOXGR",
242		#' grade_groups = grade_groups
243		#' ) %>%
244		#' build_table(df, alt_counts_df = df_adsl)
245		count_occurrences_by_grade <- function(lyt,
246		var,
247		var_labels = var,
248		show_labels = "default",
249		...,
250		table_names = var,
251		.stats = NULL,
252		.formats = NULL,
253		.indent_mods = NULL,
254		.labels = NULL) {
255	7x	afun <- make_afun(
256	7x	a_count_occurrences_by_grade,
257	7x	.stats = .stats,
258	7x	.formats = .formats,
259	7x	.indent_mods = .indent_mods,
260	7x	.ungroup_stats = "count_fraction"
261		)
262
263	7x	analyze(
264	7x	lyt = lyt,
265	7x	vars = var,
266	7x	var_labels = var_labels,
267	7x	show_labels = show_labels,
268	7x	afun = afun,
269	7x	table_names = table_names,
270	7x	extra_args = list(...)
271		)
272		}
273
274		#' @describeIn count_occurrences_by_grade Layout creating function which adds content rows using the
275		#' statistics function and additional format arguments (see below).
276		#' @export
277		#' @examples
278		#'
279		#' # Layout creating function with custom format.
280		#' basic_table() %>%
281		#' add_colcounts() %>%
282		#' split_rows_by("ARM", child_labels = "visible", nested = TRUE) %>%
283		#' summarize_occurrences_by_grade(
284		#' var = "AESEV",
285		#' .formats = c("count_fraction" = "xx.xx (xx.xx%)")
286		#' ) %>%
287		#' build_table(df, alt_counts_df = df_adsl)
288		#'
289		#' basic_table() %>%
290		#' add_colcounts() %>%
291		#' split_rows_by("ARM", child_labels = "visible", nested = TRUE) %>%
292		#' summarize_occurrences_by_grade(
293		#' var = "AETOXGR",
294		#' grade_groups = grade_groups
295		#' ) %>%
296		#' build_table(df, alt_counts_df = df_adsl)
297		summarize_occurrences_by_grade <- function(lyt,
298		var,
299		...,
300		.stats = NULL,
301		.formats = NULL,
302		.indent_mods = NULL,
303		.labels = NULL) {
304	2x	cfun <- make_afun(
305	2x	a_count_occurrences_by_grade,
306	2x	.stats = .stats,
307	2x	.formats = .formats,
308	2x	.labels = .labels,
309	2x	.indent_mods = .indent_mods,
310	2x	.ungroup_stats = "count_fraction"
311		)
312
313	2x	summarize_row_groups(
314	2x	lyt = lyt,
315	2x	var = var,
316	2x	cfun = cfun,
317	2x	extra_args = list(...)
318		)
319		}

1		#' Helper Functions for Cox Proportional Hazards Regression
2		#'
3		#' @description `r lifecycle::badge("stable")`
4		#'
5		#' Helper functions used in [fit_coxreg_univar()] and [fit_coxreg_multivar()].
6		#'
7		#' @inheritParams argument_convention
8		#' @seealso [cox_regression]
9		#'
10		#' @name h_cox_regression
11		NULL
12
13		#' @describeIn h_cox_regression Helper for Cox Regression Formula
14		#'
15		#' Creates a list of formulas. It is used internally by [fit_coxreg_univar()]
16		#' for the comparison of univariate Cox regression models.
17		#'
18		#' @inheritParams argument_convention
19		#' @inheritParams control_coxreg
20		#'
21		#' @return
22		#' The function `h_coxreg_univar_formulas` returns a `character` vector coercible
23		#' into formulas (e.g [stats::as.formula()]).
24		#'
25		#' @examples
26		#' # `h_coxreg_univar_formulas`
27		#'
28		#' ## Simple formulas.
29		#' h_coxreg_univar_formulas(
30		#' variables = list(
31		#' time = "time", event = "status", arm = "armcd", covariates = c("X", "y")
32		#' )
33		#' )
34		#'
35		#' ## Addition of an optional strata.
36		#' h_coxreg_univar_formulas(
37		#' variables = list(
38		#' time = "time", event = "status", arm = "armcd", covariates = c("X", "y"),
39		#' strata = "SITE"
40		#' )
41		#' )
42		#'
43		#' ## Inclusion of the interaction term.
44		#' h_coxreg_univar_formulas(
45		#' variables = list(
46		#' time = "time", event = "status", arm = "armcd", covariates = c("X", "y"),
47		#' strata = "SITE"
48		#' ),
49		#' interaction = TRUE
50		#' )
51		#'
52		#' ## Only covariates fitted in separate models.
53		#' h_coxreg_univar_formulas(
54		#' variables = list(
55		#' time = "time", event = "status", covariates = c("X", "y")
56		#' )
57		#' )
58		#'
59		#' @export
60		h_coxreg_univar_formulas <- function(variables,
61		interaction = FALSE) {
62	18x	checkmate::assert_list(variables, names = "named")
63	18x	has_arm <- "arm" %in% names(variables)
64	18x	arm_name <- if (has_arm) "arm" else NULL
65
66	18x	checkmate::assert_character(variables$covariates, null.ok = TRUE)
67
68	18x	checkmate::assert_flag(interaction)
69
70	18x	if (!has_arm \|\| is.null(variables$covariates)) {
71	7x	checkmate::assert_false(interaction)
72		}
73
74	16x	assert_list_of_variables(variables[c(arm_name, "event", "time")])
75
76	16x	if (!is.null(variables$covariates)) {
77	15x	forms <- paste0(
78	15x	"survival::Surv(", variables$time, ", ", variables$event, ") ~ ",
79	15x	ifelse(has_arm, variables$arm, "1"),
80	15x	ifelse(interaction, " * ", " + "),
81	15x	variables$covariates,
82	15x	ifelse(
83	15x	!is.null(variables$strata),
84	15x	paste0(" + strata(", paste0(variables$strata, collapse = ", "), ")"),
85		""
86		)
87		)
88		} else {
89	1x	forms <- NULL
90		}
91	16x	nams <- variables$covariates
92	16x	if (has_arm) {
93	12x	ref <- paste0(
94	12x	"survival::Surv(", variables$time, ", ", variables$event, ") ~ ",
95	12x	variables$arm,
96	12x	ifelse(
97	12x	!is.null(variables$strata),
98	12x	paste0(
99	12x	" + strata(", paste0(variables$strata, collapse = ", "), ")"
100		),
101		""
102		)
103		)
104	12x	forms <- c(ref, forms)
105	12x	nams <- c("ref", nams)
106		}
107	16x	stats::setNames(forms, nams)
108		}
109
110		#' @describeIn h_cox_regression Helper for Multi-variable Cox Regression Formula
111		#'
112		#' Creates a formulas string. It is used internally by [fit_coxreg_multivar()]
113		#' for the comparison of multi-variable Cox regression models. Interactions will not
114		#' be included in multi-variable Cox regression model.
115		#'
116		#' @inheritParams argument_convention
117		#'
118		#' @return
119		#' The function `h_coxreg_univar_formulas` returns a `character` vector coercible
120		#' into formulas (e.g [stats::as.formula()]).
121		#'
122		#' @export
123		#'
124		#' @examples
125		#' # `h_coxreg_multivar_formula`
126		#'
127		#' h_coxreg_multivar_formula(
128		#' variables = list(
129		#' time = "AVAL", event = "event", arm = "ARMCD", covariates = c("RACE", "AGE")
130		#' )
131		#' )
132		#'
133		#' # Addition of an optional strata.
134		#' h_coxreg_multivar_formula(
135		#' variables = list(
136		#' time = "AVAL", event = "event", arm = "ARMCD", covariates = c("RACE", "AGE"),
137		#' strata = "SITE"
138		#' )
139		#' )
140		#'
141		#' # Example without treatment arm.
142		#' h_coxreg_multivar_formula(
143		#' variables = list(
144		#' time = "AVAL", event = "event", covariates = c("RACE", "AGE"),
145		#' strata = "SITE"
146		#' )
147		#' )
148		h_coxreg_multivar_formula <- function(variables) {
149	51x	checkmate::assert_list(variables, names = "named")
150	51x	has_arm <- "arm" %in% names(variables)
151	51x	arm_name <- if (has_arm) "arm" else NULL
152
153	51x	checkmate::assert_character(variables$covariates, null.ok = TRUE)
154
155	51x	assert_list_of_variables(variables[c(arm_name, "event", "time")])
156
157	51x	y <- paste0(
158	51x	"survival::Surv(", variables$time, ", ", variables$event, ") ~ ",
159	51x	ifelse(has_arm, variables$arm, "1")
160		)
161	51x	if (length(variables$covariates) > 0) {
162	12x	y <- paste(y, paste(variables$covariates, collapse = " + "), sep = " + ")
163		}
164	51x	if (!is.null(variables$strata)) {
165	5x	y <- paste0(y, " + strata(", paste0(variables$strata, collapse = ", "), ")")
166		}
167	51x	y
168		}
169
170		#' @describeIn h_cox_regression Utility function to help tabulate the result of
171		#' a univariate Cox regression model.
172		#'
173		#' @inheritParams argument_convention
174		#' @inheritParams cox_regression_inter
175		#' @param effect (`string`)\cr the treatment variable.
176		#' @param mod (`coxph`)\cr Cox regression model fitted by [survival::coxph()].
177		#'
178		#' @examples
179		#' library(survival)
180		#'
181		#' dta_simple <- data.frame(
182		#' time = c(5, 5, 10, 10, 5, 5, 10, 10),
183		#' status = c(0, 0, 1, 0, 0, 1, 1, 1),
184		#' armcd = factor(LETTERS[c(1, 1, 1, 1, 2, 2, 2, 2)], levels = c("A", "B")),
185		#' var1 = c(45, 55, 65, 75, 55, 65, 85, 75),
186		#' var2 = c("F", "M", "F", "M", "F", "M", "F", "U")
187		#' )
188		#' mod <- coxph(Surv(time, status) ~ armcd + var1, data = dta_simple)
189		#' result <- h_coxreg_univar_extract(
190		#' effect = "armcd", covar = "armcd", mod = mod, data = dta_simple
191		#' )
192		#' result
193		#'
194		#' @export
195		h_coxreg_univar_extract <- function(effect,
196		covar,
197		data,
198		mod,
199		control = control_coxreg()) {
200	12x	checkmate::assert_string(covar)
201	12x	checkmate::assert_string(effect)
202	12x	checkmate::assert_class(mod, "coxph")
203	12x	test_statistic <- c(wald = "Wald", likelihood = "LR")[control$pval_method]
204
205	12x	mod_aov <- muffled_car_anova(mod, test_statistic)
206	12x	msum <- summary(mod, conf.int = control$conf_level)
207	12x	sum_cox <- broom::tidy(msum)
208
209		# Combine results together.
210	12x	effect_aov <- mod_aov[effect, , drop = TRUE]
211	12x	pval <- effect_aov[[grep(pattern = "Pr", x = names(effect_aov)), drop = TRUE]]
212	12x	sum_main <- sum_cox[grepl(effect, sum_cox$level), ]
213
214	12x	term_label <- if (effect == covar) {
215	5x	paste0(
216	5x	levels(data[[covar]])[2],
217	5x	" vs control (",
218	5x	levels(data[[covar]])[1],
219		")"
220		)
221		} else {
222	7x	unname(labels_or_names(data[covar]))
223		}
224	12x	data.frame(
225	12x	effect = ifelse(covar == effect, "Treatment:", "Covariate:"),
226	12x	term = covar,
227	12x	term_label = term_label,
228	12x	level = levels(data[[effect]])[2],
229	12x	n = mod[["n"]],
230	12x	hr = unname(sum_main["exp(coef)"]),
231	12x	lcl = unname(sum_main[grep("lower", names(sum_main))]),
232	12x	ucl = unname(sum_main[grep("upper", names(sum_main))]),
233	12x	pval = pval,
234	12x	stringsAsFactors = FALSE
235		)
236		}
237
238		#' @describeIn h_cox_regression Tabulation of Multi-variable Cox Regressions
239		#'
240		#' Utility function to help tabulate the result of a multi-variable Cox regression model
241		#' for a treatment/covariate variable.
242		#'
243		#' @inheritParams argument_convention
244		#' @inheritParams h_coxreg_univar_extract
245		#' @export
246		#'
247		#' @examples
248		#' mod <- coxph(Surv(time, status) ~ armcd + var1, data = dta_simple)
249		#' result <- h_coxreg_multivar_extract(
250		#' var = "var1", mod = mod, data = dta_simple
251		#' )
252		#' result
253		h_coxreg_multivar_extract <- function(var,
254		data,
255		mod,
256		control = control_coxreg()) {
257	52x	test_statistic <- c(wald = "Wald", likelihood = "LR")[control$pval_method]
258	52x	mod_aov <- muffled_car_anova(mod, test_statistic)
259
260	52x	msum <- summary(mod, conf.int = control$conf_level)
261	52x	sum_anova <- broom::tidy(mod_aov)
262	52x	sum_cox <- broom::tidy(msum)
263
264	52x	ret_anova <- sum_anova[sum_anova$term == var, c("term", "p.value")]
265	52x	names(ret_anova)[2] <- "pval"
266	52x	if (is.factor(data[[var]])) {
267	10x	ret_cox <- sum_cox[startsWith(prefix = var, x = sum_cox$level), !(names(sum_cox) %in% "exp(-coef)")]
268		} else {
269	42x	ret_cox <- sum_cox[(var == sum_cox$level), !(names(sum_cox) %in% "exp(-coef)")]
270		}
271	52x	names(ret_cox)[1:4] <- c("pval", "hr", "lcl", "ucl")
272	52x	varlab <- unname(labels_or_names(data[var]))
273	52x	ret_cox$term <- varlab
274
275	52x	if (is.numeric(data[[var]])) {
276	42x	ret <- ret_cox
277	42x	ret$term_label <- ret$term
278	10x	} else if (length(levels(data[[var]])) <= 2) {
279	6x	ret_anova$pval <- NA
280	6x	ret_anova$term_label <- paste0(varlab, " (reference = ", levels(data[[var]])[1], ")")
281	6x	ret_cox$level <- gsub(var, "", ret_cox$level)
282	6x	ret_cox$term_label <- ret_cox$level
283	6x	ret <- dplyr::bind_rows(ret_anova, ret_cox)
284		} else {
285	4x	ret_anova$term_label <- paste0(varlab, " (reference = ", levels(data[[var]])[1], ")")
286	4x	ret_cox$level <- gsub(var, "", ret_cox$level)
287	4x	ret_cox$term_label <- ret_cox$level
288	4x	ret <- dplyr::bind_rows(ret_anova, ret_cox)
289		}
290
291	52x	as.data.frame(ret)
292		}

1		#' Patient Counts for Laboratory Events (Worsen From Baseline) by Highest Grade Post-Baseline
2		#'
3		#' @description `r lifecycle::badge("stable")`
4		#'
5		#' Patient count and fraction for laboratory events (worsen from baseline) shift table.
6		#'
7		#' @inheritParams argument_convention
8		#'
9		#' @seealso Relevant helper functions [h_adlb_worsen()] and [h_worsen_counter()].
10		#'
11		#' @name abnormal_by_worst_grade_worsen
12		NULL
13
14		#' Helper Function to Prepare ADLB with Worst Labs
15		#'
16		#' @description `r lifecycle::badge("stable")`
17		#'
18		#' Helper function to prepare a `df` for generate the patient count shift table
19		#'
20		#' @param adlb (`data.frame`)\cr `ADLB` dataframe
21		#' @param worst_flag_low (named `vector`)\cr Worst low post-baseline lab grade flag variable
22		#' @param worst_flag_high (named `vector`)\cr Worst high post-baseline lab grade flag variable
23		#' @param direction_var (`string`)\cr Direction variable specifying the direction of the shift table of interest.
24		#' Only lab records flagged by `L`, `H` or `B` are included in the shift table.
25		#' * `L`: low direction only
26		#' * `H`: high direction only
27		#' * `B`: both low and high directions
28		#'
29		#' @return [h_adlb_worsen()] returns the `adlb` `data.frame` containing only the
30		#' worst labs specified according to `worst_flag_low` or `worst_flag_high` for the
31		#' direction specified according to `direction_var`. For instance, for a lab that is
32		#' needed for the low direction only, only records flagged by `worst_flag_low` are
33		#' selected. For a lab that is needed for both low and high directions, the worst
34		#' low records are selected for the low direction, and the worst high record are selected
35		#' for the high direction.
36		#' @seealso [abnormal_by_worst_grade_worsen]
37		#'
38		#' @examples
39		#' library(dplyr)
40		#'
41		#' # The direction variable, GRADDR, is based on metadata
42		#' adlb <- tern_ex_adlb %>%
43		#' mutate(
44		#' GRADDR = case_when(
45		#' PARAMCD == "ALT" ~ "B",
46		#' PARAMCD == "CRP" ~ "L",
47		#' PARAMCD == "IGA" ~ "H"
48		#' )
49		#' ) %>%
50		#' filter(SAFFL == "Y" & ONTRTFL == "Y" & GRADDR != "")
51		#'
52		#' df <- h_adlb_worsen(
53		#' adlb,
54		#' worst_flag_low = c("WGRLOFL" = "Y"),
55		#' worst_flag_high = c("WGRHIFL" = "Y"),
56		#' direction_var = "GRADDR"
57		#' )
58		#'
59		#' @export
60		h_adlb_worsen <- function(adlb,
61		worst_flag_low = NULL,
62		worst_flag_high = NULL,
63		direction_var) {
64	5x	checkmate::assert_string(direction_var)
65	5x	checkmate::assert_subset(as.character(unique(adlb[[direction_var]])), c("B", "L", "H"))
66	5x	assert_df_with_variables(adlb, list("Col" = direction_var))
67
68	5x	if (any(unique(adlb[[direction_var]]) == "H")) {
69	4x	assert_df_with_variables(adlb, list("High" = names(worst_flag_high)))
70		}
71
72	5x	if (any(unique(adlb[[direction_var]]) == "L")) {
73	4x	assert_df_with_variables(adlb, list("Low" = names(worst_flag_low)))
74		}
75
76	5x	if (any(unique(adlb[[direction_var]]) == "B")) {
77	3x	assert_df_with_variables(
78	3x	adlb,
79	3x	list(
80	3x	"Low" = names(worst_flag_low),
81	3x	"High" = names(worst_flag_high)
82		)
83		)
84		}
85
86		# extract patients with worst post-baseline lab, either low or high or both
87	5x	worst_flag <- c(worst_flag_low, worst_flag_high)
88	5x	col_names <- names(worst_flag)
89	5x	filter_values <- worst_flag
90	5x	temp <- Map(
91	5x	function(x, y) which(adlb[[x]] == y),
92	5x	col_names,
93	5x	filter_values
94		)
95	5x	position_satisfy_filters <- Reduce(union, temp)
96
97		# select variables of interest
98	5x	adlb_f <- adlb[position_satisfy_filters, ]
99
100		# generate subsets for different directionality
101	5x	adlb_f_h <- adlb_f[which(adlb_f[[direction_var]] == "H"), ]
102	5x	adlb_f_l <- adlb_f[which(adlb_f[[direction_var]] == "L"), ]
103	5x	adlb_f_b <- adlb_f[which(adlb_f[[direction_var]] == "B"), ]
104
105		# for labs requiring both high and low, data is duplicated and will be stacked on top of each other
106	5x	adlb_f_b_h <- adlb_f_b
107	5x	adlb_f_b_l <- adlb_f_b
108
109		# extract data with worst lab
110	5x	if (!is.null(worst_flag_high) && !is.null(worst_flag_low)) {
111		# change H to High, L to Low
112	3x	adlb_f_h[[direction_var]] <- rep("High", nrow(adlb_f_h))
113	3x	adlb_f_l[[direction_var]] <- rep("Low", nrow(adlb_f_l))
114
115		# change, B to High and Low
116	3x	adlb_f_b_h[[direction_var]] <- rep("High", nrow(adlb_f_b_h))
117	3x	adlb_f_b_l[[direction_var]] <- rep("Low", nrow(adlb_f_b_l))
118
119	3x	adlb_out_h <- adlb_f_h[which(adlb_f_h[[names(worst_flag_high)]] == worst_flag_high), ]
120	3x	adlb_out_b_h <- adlb_f_b_h[which(adlb_f_b_h[[names(worst_flag_high)]] == worst_flag_high), ]
121	3x	adlb_out_l <- adlb_f_l[which(adlb_f_l[[names(worst_flag_low)]] == worst_flag_low), ]
122	3x	adlb_out_b_l <- adlb_f_b_l[which(adlb_f_b_l[[names(worst_flag_low)]] == worst_flag_low), ]
123
124	3x	out <- rbind(adlb_out_h, adlb_out_b_h, adlb_out_l, adlb_out_b_l)
125	2x	} else if (!is.null(worst_flag_high)) {
126	1x	adlb_f_h[[direction_var]] <- rep("High", nrow(adlb_f_h))
127	1x	adlb_f_b_h[[direction_var]] <- rep("High", nrow(adlb_f_b_h))
128
129	1x	adlb_out_h <- adlb_f_h[which(adlb_f_h[[names(worst_flag_high)]] == worst_flag_high), ]
130	1x	adlb_out_b_h <- adlb_f_b_h[which(adlb_f_b_h[[names(worst_flag_high)]] == worst_flag_high), ]
131
132	1x	out <- rbind(adlb_out_h, adlb_out_b_h)
133	1x	} else if (!is.null(worst_flag_low)) {
134	1x	adlb_f_l[[direction_var]] <- rep("Low", nrow(adlb_f_l))
135	1x	adlb_f_b_l[[direction_var]] <- rep("Low", nrow(adlb_f_b_l))
136
137	1x	adlb_out_l <- adlb_f_l[which(adlb_f_l[[names(worst_flag_low)]] == worst_flag_low), ]
138	1x	adlb_out_b_l <- adlb_f_b_l[which(adlb_f_b_l[[names(worst_flag_low)]] == worst_flag_low), ]
139
140	1x	out <- rbind(adlb_out_l, adlb_out_b_l)
141		}
142
143		# label
144	5x	formatters::var_labels(out) <- formatters::var_labels(adlb_f, fill = FALSE)
145		# NA
146	5x	out
147		}
148
149		#' Helper Function to Analyze Patients for [s_count_abnormal_lab_worsen_by_baseline()]
150		#'
151		#' @description `r lifecycle::badge("stable")`
152		#'
153		#' Helper function to count the number of patients and the fraction of patients according to
154		#' highest post-baseline lab grade variable `.var`, baseline lab grade variable `baseline_var`,
155		#' and the direction of interest specified in `direction_var`.
156		#'
157		#' @inheritParams argument_convention
158		#' @inheritParams h_adlb_worsen
159		#' @param baseline_var (`string`)\cr baseline lab grade variable
160		#' @return [h_worsen_counter()] returns the counts and fraction of patients
161		#' whose worst post-baseline lab grades are worse than their baseline grades, for
162		#' post-baseline worst grades "1", "2", "3", "4" and "Any".
163		#' @seealso [abnormal_by_worst_grade_worsen]
164		#'
165		#' @examples
166		#' library(dplyr)
167		#'
168		#' # The direction variable, GRADDR, is based on metadata
169		#' adlb <- tern_ex_adlb %>%
170		#' mutate(
171		#' GRADDR = case_when(
172		#' PARAMCD == "ALT" ~ "B",
173		#' PARAMCD == "CRP" ~ "L",
174		#' PARAMCD == "IGA" ~ "H"
175		#' )
176		#' ) %>%
177		#' filter(SAFFL == "Y" & ONTRTFL == "Y" & GRADDR != "")
178		#'
179		#' df <- h_adlb_worsen(
180		#' adlb,
181		#' worst_flag_low = c("WGRLOFL" = "Y"),
182		#' worst_flag_high = c("WGRHIFL" = "Y"),
183		#' direction_var = "GRADDR"
184		#' )
185		#'
186		#' # `h_worsen_counter`
187		#' h_worsen_counter(
188		#' df %>% filter(PARAMCD == "CRP" & GRADDR == "Low"),
189		#' id = "USUBJID",
190		#' .var = "ATOXGR",
191		#' baseline_var = "BTOXGR",
192		#' direction_var = "GRADDR"
193		#' )
194		#'
195		#' @export
196		h_worsen_counter <- function(df, id, .var, baseline_var, direction_var) {
197	17x	checkmate::assert_string(id)
198	17x	checkmate::assert_string(.var)
199	17x	checkmate::assert_string(baseline_var)
200	17x	checkmate::assert_scalar(unique(df[[direction_var]]))
201	17x	checkmate::assert_subset(unique(df[[direction_var]]), c("High", "Low"))
202	17x	assert_df_with_variables(df, list(val = c(id, .var, baseline_var, direction_var)))
203
204		# remove post-baseline missing
205	17x	df <- df[df[[.var]] != "<Missing>", ]
206
207		# obtain directionality
208	17x	direction <- unique(df[[direction_var]])
209
210	17x	if (direction == "Low") {
211	10x	grade <- -1:-4
212	10x	worst_grade <- -4
213	7x	} else if (direction == "High") {
214	7x	grade <- 1:4
215	7x	worst_grade <- 4
216		}
217
218	17x	if (nrow(df) > 0) {
219	17x	by_grade <- lapply(grade, function(i) {
220		# filter baseline values that is less than i or <Missing>
221	68x	df_temp <- df[df[[baseline_var]] %in% c((i + sign(i) * -1):(-1 * worst_grade), "<Missing>"), ]
222		# num: number of patients with post-baseline worst lab equal to i
223	68x	num <- length(unique(df_temp[df_temp[[.var]] %in% i, id, drop = TRUE]))
224		# denom: number of patients with baseline values less than i or <missing> and post-baseline in the same direction
225	68x	denom <- length(unique(df_temp[[id]]))
226	68x	rm(df_temp)
227	68x	c(num = num, denom = denom)
228		})
229		} else {
230	!	by_grade <- lapply(1, function(i) {
231	!	c(num = 0, denom = 0)
232		})
233		}
234
235	17x	names(by_grade) <- as.character(seq_along(by_grade))
236
237		# baseline grade less 4 or missing
238	17x	df_temp <- df[!df[[baseline_var]] %in% worst_grade, ]
239
240		# denom: number of patients with baseline values less than 4 or <missing> and post-baseline in the same direction
241	17x	denom <- length(unique(df_temp[, id, drop = TRUE]))
242
243		# condition 1: missing baseline and in the direction of abnormality
244	17x	con1 <- which(df_temp[[baseline_var]] == "<Missing>" & df_temp[[.var]] %in% grade)
245	17x	df_temp_nm <- df_temp[which(df_temp[[baseline_var]] != "<Missing>" & df_temp[[.var]] %in% grade), ]
246
247		# condition 2: if post-baseline values are present then post-baseline values must be worse than baseline
248	17x	if (direction == "Low") {
249	10x	con2 <- which(as.numeric(as.character(df_temp_nm[[.var]])) < as.numeric(as.character(df_temp_nm[[baseline_var]])))
250		} else {
251	7x	con2 <- which(as.numeric(as.character(df_temp_nm[[.var]])) > as.numeric(as.character(df_temp_nm[[baseline_var]])))
252		}
253
254		# number of patients satisfy either conditions 1 or 2
255	17x	num <- length(unique(df_temp[union(con1, con2), id, drop = TRUE]))
256
257	17x	list(fraction = c(by_grade, list("Any" = c(num = num, denom = denom))))
258		}
259
260		#' @describeIn abnormal_by_worst_grade_worsen Statistics function which calculates the
261		#' counts and fraction of patients whose worst post-baseline lab grades are worse than
262		#' their baseline grades, for post-baseline worst grades "1", "2", "3", "4" and "Any".
263		#'
264		#' @param variables (named `list` of `string`)\cr list of additional analysis variables including:
265		#' * `id` (`string`)\cr subject variable name.
266		#' * `baseline_var` (`string`)\cr name of the data column containing baseline toxicity variable.
267		#' * `direction_var` (`string`)\cr see `direction_var` for more details.
268		#' @return [s_count_abnormal_lab_worsen_by_baseline()] returns the
269		#' counts and fraction of patients whose worst post-baseline lab grades are worse than
270		#' their baseline grades, for post-baseline worst grades "1", "2", "3", "4" and "Any".
271		#'
272		#' @examples
273		#' library(dplyr)
274		#'
275		#' # The direction variable, GRADDR, is based on metadata
276		#' adlb <- tern_ex_adlb %>%
277		#' mutate(
278		#' GRADDR = case_when(
279		#' PARAMCD == "ALT" ~ "B",
280		#' PARAMCD == "CRP" ~ "L",
281		#' PARAMCD == "IGA" ~ "H"
282		#' )
283		#' ) %>%
284		#' filter(SAFFL == "Y" & ONTRTFL == "Y" & GRADDR != "")
285		#'
286		#' df <- h_adlb_worsen(
287		#' adlb,
288		#' worst_flag_low = c("WGRLOFL" = "Y"),
289		#' worst_flag_high = c("WGRHIFL" = "Y"),
290		#' direction_var = "GRADDR"
291		#' )
292		#' # Internal function - s_count_abnormal_lab_worsen_by_baseline
293		#' \dontrun{
294		#' # Patients with worsening lab grade for CRP in the direction of low
295		#' s_count_abnormal_lab_worsen_by_baseline(
296		#' df = df %>% filter(ARMCD == "ARM A" & PARAMCD == "CRP"),
297		#' .var = "ATOXGR",
298		#' variables = list(
299		#' id = "USUBJID",
300		#' baseline_var = "BTOXGR",
301		#' direction_var = "GRADDR"
302		#' )
303		#' )
304		#' }
305		#'
306		#' @keywords internal
307		s_count_abnormal_lab_worsen_by_baseline <- function(df, # nolint
308		.var = "ATOXGR",
309		variables = list(
310		id = "USUBJID",
311		baseline_var = "BTOXGR",
312		direction_var = "GRADDR"
313		)) {
314	1x	checkmate::assert_string(.var)
315	1x	checkmate::assert_set_equal(names(variables), c("id", "baseline_var", "direction_var"))
316	1x	checkmate::assert_string(variables$id)
317	1x	checkmate::assert_string(variables$baseline_var)
318	1x	checkmate::assert_string(variables$direction_var)
319	1x	assert_df_with_variables(df, c(aval = .var, variables[1:3]))
320	1x	assert_list_of_variables(variables)
321
322	1x	h_worsen_counter(df, variables$id, .var, variables$baseline_var, variables$direction_var)
323		}
324
325
326		#' @describeIn abnormal_by_worst_grade_worsen
327		#'
328		#' @return [a_count_abnormal_lab_worsen_by_baseline()] returns the corresponding list with
329		#' formatted [rtables::CellValue()].
330		#'
331		#' @examples
332		#' # Internal function - a_count_abnormal_lab_worsen_by_baseline
333		#' \dontrun{
334		#' a_count_abnormal_lab_worsen_by_baseline(
335		#' df = df %>% filter(ARMCD == "ARM A" & PARAMCD == "CRP"),
336		#' .var = "ATOXGR",
337		#' variables = list(id = "USUBJID", baseline_var = "BTOXGR", direction_var = "GRADDR")
338		#' )
339		#' }
340		#'
341		#' @keywords internal
342		a_count_abnormal_lab_worsen_by_baseline <- make_afun( # nolint
343		s_count_abnormal_lab_worsen_by_baseline,
344		.formats = c(fraction = format_fraction),
345		.ungroup_stats = "fraction"
346		)
347
348		#' @describeIn abnormal_by_worst_grade_worsen Layout creating function which can be used for creating tables,
349		#' which can take statistics function arguments and additional format arguments (see below).
350		#'
351		#' @examples
352		#' basic_table() %>%
353		#' split_cols_by("ARMCD") %>%
354		#' add_colcounts() %>%
355		#' split_rows_by("PARAMCD") %>%
356		#' split_rows_by("GRADDR") %>%
357		#' count_abnormal_lab_worsen_by_baseline(
358		#' var = "ATOXGR",
359		#' variables = list(
360		#' id = "USUBJID",
361		#' baseline_var = "BTOXGR",
362		#' direction_var = "GRADDR"
363		#' )
364		#' ) %>%
365		#' append_topleft("Direction of Abnormality") %>%
366		#' build_table(df = df, alt_counts_df = tern_ex_adsl)
367		#'
368		#' @export
369		count_abnormal_lab_worsen_by_baseline <- function(lyt, # nolint
370		var,
371		...,
372		table_names = NULL,
373		.stats = NULL,
374		.formats = NULL,
375		.labels = NULL,
376		.indent_mods = NULL) {
377	1x	checkmate::assert_string(var)
378
379	1x	afun <- make_afun(
380	1x	a_count_abnormal_lab_worsen_by_baseline,
381	1x	.stats = .stats,
382	1x	.formats = .formats,
383	1x	.labels = .labels,
384	1x	.indent_mods = .indent_mods
385		)
386
387	1x	lyt <- analyze(
388	1x	lyt = lyt,
389	1x	vars = var,
390	1x	afun = afun,
391	1x	extra_args = list(...),
392	1x	show_labels = "hidden"
393		)
394
395	1x	lyt
396		}

1		#' Additional Assertions for `checkmate`
2		#'
3		#' @description
4		#' Additional assertion functions which can be used together with the `checkmate` package.
5		#'
6		#' @param x (`any`)\cr object to test.
7		#' @param df (`data.frame`)\cr data set to test.
8		#' @param variables (named `list` of `character`)\cr list of variables to test.
9		#' @param include_boundaries (`logical`)\cr whether to include boundaries when testing
10		#' for proportions.
11		#' @param na_level (`character`)\cr the string you have been using to represent NA or
12		#' missing data. For `NA` values please consider using directly `base::is.na` or
13		#' similar approaches.
14		#' @inheritParams checkmate::assert_factor
15		#' @param (`integer`)\cr minimum number of factor levels. Default is `1`.
16		#' @param ... a collection of objects to test.
17		#' @name assertions
18		NULL
19
20		check_list_of_variables <- function(x) {
21		# drop NULL elements in list
22	1857x	x <- Filter(Negate(is.null), x)
23
24	1857x	res <- checkmate::check_list(x,
25	1857x	names = "named",
26	1857x	min.len = 1,
27	1857x	any.missing = FALSE,
28	1857x	types = "character"
29		)
30		# no empty strings allowed
31	1857x	if (isTRUE(res)) {
32	1852x	res <- checkmate::check_character(unlist(x), min.chars = 1)
33		}
34	1857x	return(res)
35		}
36		#' @describeIn assertions Check whether `x` is a valid list of variable names.
37		#' `NULL` elements of the list `x` are dropped out with `Filter(Negate(is.null), x)`.
38		#'
39		#' @examples
40		#' # Check whether `x` is a valid list of variable names.
41		#'
42		#' # Internal function - assert_list_of_variables
43		#' \dontrun{
44		#' assert_list_of_variables(list(val = "a"))
45		#' assert_list_of_variables(list(val = c("a", "b")))
46		#' assert_list_of_variables(list(val = c("a", "b"), val2 = NULL))
47		#'
48		#' # The following calls fail
49		#' assert_list_of_variables(list(1, 2))
50		#' assert_list_of_variables(list("bla" = 2))
51		#' }
52		#'
53		#' @keywords internal
54		assert_list_of_variables <- checkmate::makeAssertionFunction(check_list_of_variables)
55
56		check_df_with_variables <- function(df, variables, na_level = NULL) {
57	1681x	checkmate::assert_data_frame(df)
58	1679x	assert_list_of_variables(variables)
59
60		# flag for equal variables and column names
61	1677x	err_flag <- all(unlist(variables) %in% colnames(df))
62	1677x	checkmate::assert_flag(err_flag)
63
64	1677x	if (isFALSE(err_flag)) {
65	5x	vars <- setdiff(unlist(variables), colnames(df))
66	5x	return(paste(
67	5x	deparse(substitute(df)),
68	5x	"does not contain all specified variables as column names. Missing from dataframe:",
69	5x	paste(vars, collapse = ", ")
70		))
71		}
72		# checking if na_level is present and in which column
73	1672x	if (!is.null(na_level)) {
74	9x	checkmate::assert_string(na_level)
75	9x	res <- unlist(lapply(as.list(df)[unlist(variables)], function(x) any(x == na_level)))
76	9x	if (any(res)) {
77	1x	return(paste0(
78	1x	deparse(substitute(df)), " contains explicit na_level (", na_level,
79	1x	") in the following columns: ", paste0(unlist(variables)[res],
80	1x	collapse = ", "
81		)
82		))
83		}
84		}
85	1671x	return(TRUE)
86		}
87		#' @describeIn assertions Check whether `df` is a data frame with the analysis `variables`.
88		#' Please notice how this produces an error when not all variables are present in the
89		#' data.frame while the opposite is not required.
90		#'
91		#' @examples
92		#' # Check whether `df` contains the analysis `variables`.
93		#'
94		#' # Internal function - assert_df_with_variables
95		#' \dontrun{
96		#' assert_df_with_variables(
97		#' df = data.frame(a = 5, b = 3),
98		#' variables = list(val = "a")
99		#' )
100		#' assert_df_with_variables(
101		#' df = data.frame(a = 5, b = 3),
102		#' variables = list(val = c("a", "b"))
103		#' )
104		#' assert_df_with_variables(
105		#' df = data.frame(a = 5, b = 3),
106		#' variables = list(val = c("a", "b"))
107		#' )
108		#' assert_df_with_variables(
109		#' df = data.frame(a = 5, b = 3, e = "<Missing>"),
110		#' variables = list(val = c("a", "b")), na_level = "<Missing>"
111		#' )
112		#'
113		#' # The following calls fail
114		#' assert_df_with_variables(
115		#' df = matrix(1:5, ncol = 2, nrow = 3),
116		#' variables = list(val = "a")
117		#' )
118		#' assert_df_with_variables(
119		#' df = data.frame(a = 5, b = 3),
120		#' variables = list(val = c("a", "b", "c"))
121		#' )
122		#' assert_df_with_variables(
123		#' df = data.frame(a = 5, b = 3, e = "<Missing>"),
124		#' variables = list(val = c("a", "b", "e")), na_level = "<Missing>"
125		#' )
126		#' }
127		#'
128		#' @keywords internal
129		assert_df_with_variables <- checkmate::makeAssertionFunction(check_df_with_variables)
130
131		check_valid_factor <- function(x,
132		min.levels = 1, # nolint
133		max.levels = NULL, # nolint
134		null.ok = TRUE, # nolint
135		any.missing = TRUE, # nolint
136		n.levels = NULL, # nolint
137		len = NULL) {
138		# checks on levels insertion
139	772x	checkmate::assert_int(min.levels, lower = 1)
140
141		# main factor check
142	772x	res <- checkmate::check_factor(x,
143	772x	min.levels = min.levels,
144	772x	null.ok = null.ok,
145	772x	max.levels = max.levels,
146	772x	any.missing = any.missing,
147	772x	n.levels = n.levels
148		)
149
150		# no empty strings allowed
151	772x	if (isTRUE(res)) {
152	757x	res <- checkmate::check_character(levels(x), min.chars = 1)
153		}
154
155	772x	return(res)
156		}
157		#' @describeIn assertions Check whether `x` is a valid factor (has levels and no empty
158		#' string levels). Note that `NULL` and `NA` elements are allowed.
159		#'
160		#' @examples
161		#' # Check whether `x` is a valid factor.
162		#'
163		#' # Internal function - assert_valid_factor
164		#' \dontrun{
165		#' assert_valid_factor(factor(c("a", NULL)))
166		#' assert_valid_factor(factor(c("a", "b")))
167		#' assert_valid_factor(factor(c("a", "b")), len = 2)
168		#' assert_valid_factor(factor(c("a", NA)), any.missing = TRUE)
169		#' assert_valid_factor(factor("A", levels = c("A", "B")))
170		#'
171		#' # The following calls fail
172		#' assert_valid_factor(-1)
173		#' assert_valid_factor(factor(c("a", "")))
174		#' assert_valid_factor(factor(c("a", NA)), any.missing = FALSE)
175		#' assert_valid_factor(factor(NULL))
176		#' assert_valid_factor(factor(c(NULL, "")))
177		#' assert_valid_factor(factor())
178		#' }
179		#'
180		#' @keywords internal
181		assert_valid_factor <- checkmate::makeAssertionFunction(check_valid_factor)
182
183
184		check_df_with_factors <- function(df,
185		variables,
186		min.levels = 1, # nolint
187		max.levels = NULL, # nolint
188		any.missing = TRUE, # nolint
189		na_level = NULL) {
190	170x	res <- check_df_with_variables(df, variables, na_level)
191		# checking if all the columns specified by variables are valid factors
192	169x	if (isTRUE(res)) {
193		# searching the data.frame with selected columns (variables) as a list
194	167x	res <- lapply(
195	167x	X = as.list(df)[unlist(variables)],
196	167x	FUN = check_valid_factor,
197	167x	min.levels = min.levels,
198	167x	max.levels = max.levels,
199	167x	any.missing = any.missing
200		)
201	167x	res_lo <- unlist(vapply(res, Negate(isTRUE), logical(1)))
202	167x	if (any(res_lo)) {
203	6x	return(paste0(
204	6x	deparse(substitute(df)), " does not contain only factor variables among:",
205	6x	"\n* Column `", paste0(unlist(variables)[res_lo],
206	6x	"` of the data.frame -> ", res[res_lo],
207	6x	collapse = "\n* "
208		)
209		))
210		} else {
211	161x	res <- TRUE
212		}
213		}
214	163x	return(res)
215		}
216		#' @describeIn assertions Check whether `df` is a data frame where the analysis `variables`
217		#' are all factors. Note that the creation of `NA` by direct call of `factor()` will
218		#' trim `NA` levels out of the vector list itself.
219		#'
220		#' @examples
221		#' # Check whether `df` contains all factor analysis `variables`.
222		#' adf <- data.frame(a = factor(c("A", "B")), b = 3)
223		#' bdf <- data.frame(a = factor(letters[1:3]), b = factor(c(1, 2, 3)), d = 3)
224		#'
225		#' # Internal function - assert_df_with_factors
226		#' \dontrun{
227		#' assert_df_with_factors(df = adf, variables = list(val = "a"))
228		#' assert_df_with_factors(df = adf, variables = list(val = "a"), min.levels = 1)
229		#' assert_df_with_factors(df = adf, variables = list(val = "a"), min.levels = 2, max.levels = 2)
230		#' assert_df_with_factors(
231		#' df = data.frame(a = factor(c("A", NA, "B")), b = 3),
232		#' variable = list(val = "a"),
233		#' min.levels = 2,
234		#' max.levels = 2
235		#' )
236		#'
237		#' # The following calls fail
238		#' assert_df_with_factors(df = adf, variables = list(val = "a"), min.levels = 1, max.levels = 1)
239		#' assert_df_with_factors(df = adf, variables = list(val = "a"), min.levels = 1, max.levels = 1)
240		#' assert_df_with_factors(df = adf, variables = list(val = "a", val = "b", val = ""))
241		#' assert_df_with_factors(df = adf, variables = list(val = "a", val = "b", val = "d"))
242		#' assert_df_with_factors(
243		#' df = bdf,
244		#' variables = list(val = "a", val = "b"),
245		#' min.levels = 1,
246		#' max.levels = 1
247		#' )
248		#' }
249		#'
250		#' @keywords internal
251		assert_df_with_factors <- checkmate::makeAssertionFunction(check_df_with_factors)
252
253		#' @describeIn assertions Check whether `x` is a proportion: number between 0 and 1.
254		#'
255		#' @examples
256		#' # Check whether `x` is between 0 and 1.
257		#' # Internal function - assert_proportion_value
258		#' \dontrun{
259		#' assert_proportion_value(x = 0, include_boundaries = TRUE)
260		#' assert_proportion_value(x = 0.3)
261		#'
262		#' # These fail
263		#' assert_proportion_value(x = 1.3)
264		#' assert_proportion_value(x = 1)
265		#' }
266		#'
267		#' @keywords internal
268		assert_proportion_value <- function(x, include_boundaries = FALSE) {
269	5667x	checkmate::assert_number(x, lower = 0, upper = 1)
270	5655x	checkmate::assert_flag(include_boundaries)
271	5655x	if (isFALSE(include_boundaries)) {
272	1997x	checkmate::assert_true(x > 0)
273	1995x	checkmate::assert_true(x < 1)
274		}
275		}

1		#' Helper Functions for Tabulating Binary Response by Subgroup
2		#'
3		#' Helper functions that tabulate in a data frame statistics such as response rate
4		#' and odds ratio for population subgroups.
5		#'
6		#' @details Main functionality is to prepare data for use in a layout creating function.
7		#'
8		#' @description `r lifecycle::badge("stable")`
9		#' @inheritParams argument_convention
10		#' @inheritParams response_subgroups
11		#' @param arm (`factor`)\cr the treatment group variable.
12		#' @name h_response_subgroups
13		#'
14		#' @examples
15		#' library(dplyr)
16		#' library(forcats)
17		#'
18		#' adrs <- tern_ex_adrs
19		#' adrs_labels <- formatters::var_labels(adrs)
20		#'
21		#' adrs_f <- adrs %>%
22		#' filter(PARAMCD == "BESRSPI") %>%
23		#' filter(ARM %in% c("A: Drug X", "B: Placebo")) %>%
24		#' droplevels() %>%
25		#' mutate(
26		#' # Reorder levels of factor to make the placebo group the reference arm.
27		#' ARM = fct_relevel(ARM, "B: Placebo"),
28		#' rsp = AVALC == "CR"
29		#' )
30		#' formatters::var_labels(adrs_f) <- c(adrs_labels, "Response")
31		NULL
32
33		#' @describeIn h_response_subgroups helper to prepare a data frame of binary responses by arm.
34		#' @inheritParams h_response_subgroups
35		#' @export
36		#' @examples
37		#'
38		#' h_proportion_df(
39		#' c(TRUE, FALSE, FALSE),
40		#' arm = factor(c("A", "A", "B"), levels = c("A", "B"))
41		#' )
42		h_proportion_df <- function(rsp, arm) {
43	59x	checkmate::assert_logical(rsp)
44	58x	assert_valid_factor(arm, len = length(rsp))
45	58x	non_missing_rsp <- !is.na(rsp)
46	58x	rsp <- rsp[non_missing_rsp]
47	58x	arm <- arm[non_missing_rsp]
48
49	58x	lst_rsp <- split(rsp, arm)
50	58x	lst_results <- Map(function(x, arm) {
51	116x	if (length(x) > 0) {
52	114x	s_prop <- s_proportion(df = x)
53	114x	data.frame(
54	114x	arm = arm,
55	114x	n = length(x),
56	114x	n_rsp = unname(s_prop$n_prop[1]),
57	114x	prop = unname(s_prop$n_prop[2]),
58	114x	stringsAsFactors = FALSE
59		)
60		} else {
61	2x	data.frame(
62	2x	arm = arm,
63	2x	n = 0L,
64	2x	n_rsp = NA,
65	2x	prop = NA,
66	2x	stringsAsFactors = FALSE
67		)
68		}
69	58x	}, lst_rsp, names(lst_rsp))
70
71	58x	df <- do.call(rbind, args = c(lst_results, make.row.names = FALSE))
72	58x	df$arm <- factor(df$arm, levels = levels(arm))
73	58x	df
74		}
75
76		#' @describeIn h_response_subgroups summarizes proportion of binary responses by arm and across subgroups
77		#' in a data frame. `variables` corresponds to the names of variables found in `data`, passed as a named list and
78		#' requires elements `rsp`, `arm` and optionally `subgroups`. `groups_lists` optionally specifies
79		#' groupings for `subgroups` variables.
80		#' @export
81		#'
82		#' @examples
83		#' h_proportion_subgroups_df(
84		#' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
85		#' data = adrs_f
86		#' )
87		#'
88		#' # Define groupings for BMRKR2 levels.
89		#' h_proportion_subgroups_df(
90		#' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
91		#' data = adrs_f,
92		#' groups_lists = list(
93		#' BMRKR2 = list(
94		#' "low" = "LOW",
95		#' "low/medium" = c("LOW", "MEDIUM"),
96		#' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
97		#' )
98		#' )
99		#' )
100		h_proportion_subgroups_df <- function(variables,
101		data,
102		groups_lists = list(),
103		label_all = "All Patients") {
104	13x	checkmate::assert_character(variables$rsp)
105	13x	checkmate::assert_character(variables$arm)
106	13x	checkmate::assert_character(variables$subgroups, null.ok = TRUE)
107	13x	assert_df_with_factors(data, list(val = variables$arm), min.levels = 2, max.levels = 2)
108	13x	assert_df_with_variables(data, variables)
109	13x	checkmate::assert_string(label_all)
110
111		# Add All Patients.
112	13x	result_all <- h_proportion_df(data[[variables$rsp]], data[[variables$arm]])
113	13x	result_all$subgroup <- label_all
114	13x	result_all$var <- "ALL"
115	13x	result_all$var_label <- label_all
116	13x	result_all$row_type <- "content"
117
118		# Add Subgroups.
119	13x	if (is.null(variables$subgroups)) {
120	3x	result_all
121		} else {
122	10x	l_data <- h_split_by_subgroups(data, variables$subgroups, groups_lists = groups_lists)
123
124	10x	l_result <- lapply(l_data, function(grp) {
125	42x	result <- h_proportion_df(grp$df[[variables$rsp]], grp$df[[variables$arm]])
126	42x	result_labels <- grp$df_labels[rep(1, times = nrow(result)), ]
127	42x	cbind(result, result_labels)
128		})
129	10x	result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE))
130	10x	result_subgroups$row_type <- "analysis"
131
132	10x	rbind(
133	10x	result_all,
134	10x	result_subgroups
135		)
136		}
137		}
138
139		#' @describeIn h_response_subgroups helper to prepare a data frame with estimates of
140		#' the odds ratio between a treatment and a control arm.
141		#'
142		#' @inheritParams response_subgroups
143		#' @param strata_data (`factor`, `data.frame` or `NULL`)\cr required if stratified analysis is performed.
144		#' @export
145		#'
146		#' @examples
147		#' # Unstratatified analysis.
148		#' h_odds_ratio_df(
149		#' c(TRUE, FALSE, FALSE, TRUE),
150		#' arm = factor(c("A", "A", "B", "B"), levels = c("A", "B"))
151		#' )
152		#'
153		#' # Include p-value.
154		#' h_odds_ratio_df(adrs_f$rsp, adrs_f$ARM, method = "chisq")
155		#'
156		#' # Stratatified analysis.
157		#' h_odds_ratio_df(
158		#' rsp = adrs_f$rsp,
159		#' arm = adrs_f$ARM,
160		#' strata_data = adrs_f[, c("STRATA1", "STRATA2")],
161		#' method = "cmh"
162		#' )
163		h_odds_ratio_df <- function(rsp, arm, strata_data = NULL, conf_level = 0.95, method = NULL) {
164	64x	assert_valid_factor(arm, n.levels = 2, len = length(rsp))
165
166	64x	df_rsp <- data.frame(
167	64x	rsp = rsp,
168	64x	arm = arm
169		)
170
171	64x	if (!is.null(strata_data)) {
172	11x	strata_var <- interaction(strata_data, drop = TRUE)
173	11x	strata_name <- "strata"
174
175	11x	assert_valid_factor(strata_var, len = nrow(df_rsp))
176
177	11x	df_rsp[[strata_name]] <- strata_var
178		} else {
179	53x	strata_name <- NULL
180		}
181
182	64x	l_df <- split(df_rsp, arm)
183
184	64x	if (nrow(l_df[[1]]) > 0 && nrow(l_df[[2]]) > 0) {
185		# Odds ratio and CI.
186	62x	result_odds_ratio <- s_odds_ratio(
187	62x	df = l_df[[2]],
188	62x	.var = "rsp",
189	62x	.ref_group = l_df[[1]],
190	62x	.in_ref_col = FALSE,
191	62x	.df_row = df_rsp,
192	62x	variables = list(arm = "arm", strata = strata_name),
193	62x	conf_level = conf_level
194		)
195
196	62x	df <- data.frame(
197		# Dummy column needed downstream to create a nested header.
198	62x	arm = " ",
199	62x	n_tot = unname(result_odds_ratio$n_tot["n_tot"]),
200	62x	or = unname(result_odds_ratio$or_ci["est"]),
201	62x	lcl = unname(result_odds_ratio$or_ci["lcl"]),
202	62x	ucl = unname(result_odds_ratio$or_ci["ucl"]),
203	62x	conf_level = conf_level,
204	62x	stringsAsFactors = FALSE
205		)
206
207	62x	if (!is.null(method)) {
208		# Test for difference.
209	29x	result_test <- s_test_proportion_diff(
210	29x	df = l_df[[2]],
211	29x	.var = "rsp",
212	29x	.ref_group = l_df[[1]],
213	29x	.in_ref_col = FALSE,
214	29x	variables = list(strata = strata_name),
215	29x	method = method
216		)
217
218	29x	df$pval <- as.numeric(result_test$pval)
219	29x	df$pval_label <- obj_label(result_test$pval)
220		}
221
222		# In those cases cannot go through the model so will obtain n_tot from data.
223		} else if (
224	2x	(nrow(l_df[[1]]) == 0 && nrow(l_df[[2]]) > 0) \|\|
225	2x	(nrow(l_df[[1]]) > 0 && nrow(l_df[[2]]) == 0)
226		) {
227	2x	df <- data.frame(
228		# Dummy column needed downstream to create a nested header.
229	2x	arm = " ",
230	2x	n_tot = sum(stats::complete.cases(df_rsp)),
231	2x	or = NA,
232	2x	lcl = NA,
233	2x	ucl = NA,
234	2x	conf_level = conf_level,
235	2x	stringsAsFactors = FALSE
236		)
237	2x	if (!is.null(method)) {
238	2x	df$pval <- NA
239	2x	df$pval_label <- NA
240		}
241		} else {
242	!	df <- data.frame(
243		# Dummy column needed downstream to create a nested header.
244	!	arm = " ",
245	!	n_tot = 0L,
246	!	or = NA,
247	!	lcl = NA,
248	!	ucl = NA,
249	!	conf_level = conf_level,
250	!	stringsAsFactors = FALSE
251		)
252
253	!	if (!is.null(method)) {
254	!	df$pval <- NA
255	!	df$pval_label <- NA
256		}
257		}
258
259	64x	df
260		}
261
262		#' @describeIn h_response_subgroups summarizes estimates of the odds ratio between a treatment and a control
263		#' arm across subgroups in a data frame. `variables` corresponds to the names of variables found in
264		#' `data`, passed as a named list and requires elements `rsp`, `arm` and optionally `subgroups`
265		#' and `strat`. `groups_lists` optionally specifies groupings for `subgroups` variables.
266		#' @export
267		#'
268		#' @examples
269		#' # Unstratified analysis.
270		#' h_odds_ratio_subgroups_df(
271		#' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
272		#' data = adrs_f
273		#' )
274		#'
275		#' # Stratified analysis.
276		#' h_odds_ratio_subgroups_df(
277		#' variables = list(
278		#' rsp = "rsp",
279		#' arm = "ARM",
280		#' subgroups = c("SEX", "BMRKR2"),
281		#' strat = c("STRATA1", "STRATA2")
282		#' ),
283		#' data = adrs_f
284		#' )
285		#'
286		#' # Define groupings of BMRKR2 levels.
287		#' h_odds_ratio_subgroups_df(
288		#' variables = list(
289		#' rsp = "rsp",
290		#' arm = "ARM",
291		#' subgroups = c("SEX", "BMRKR2")
292		#' ),
293		#' data = adrs_f,
294		#' groups_lists = list(
295		#' BMRKR2 = list(
296		#' "low" = "LOW",
297		#' "low/medium" = c("LOW", "MEDIUM"),
298		#' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
299		#' )
300		#' )
301		#' )
302		h_odds_ratio_subgroups_df <- function(variables,
303		data,
304		groups_lists = list(),
305		conf_level = 0.95,
306		method = NULL,
307		label_all = "All Patients") {
308	14x	checkmate::assert_character(variables$rsp)
309	14x	checkmate::assert_character(variables$arm)
310	14x	checkmate::assert_character(variables$subgroups, null.ok = TRUE)
311	14x	checkmate::assert_character(variables$strat, null.ok = TRUE)
312	14x	assert_df_with_factors(data, list(val = variables$arm), min.levels = 2, max.levels = 2)
313	14x	assert_df_with_variables(data, variables)
314	14x	checkmate::assert_string(label_all)
315
316	14x	strata_data <- if (is.null(variables$strat)) {
317	12x	NULL
318		} else {
319	2x	data[, variables$strat, drop = FALSE]
320		}
321
322		# Add All Patients.
323	14x	result_all <- h_odds_ratio_df(
324	14x	rsp = data[[variables$rsp]],
325	14x	arm = data[[variables$arm]],
326	14x	strata_data = strata_data,
327	14x	conf_level = conf_level,
328	14x	method = method
329		)
330	14x	result_all$subgroup <- label_all
331	14x	result_all$var <- "ALL"
332	14x	result_all$var_label <- label_all
333	14x	result_all$row_type <- "content"
334
335	14x	if (is.null(variables$subgroups)) {
336	3x	result_all
337		} else {
338	11x	l_data <- h_split_by_subgroups(data, variables$subgroups, groups_lists = groups_lists)
339
340	11x	l_result <- lapply(l_data, function(grp) {
341	46x	grp_strata_data <- if (is.null(variables$strat)) {
342	38x	NULL
343		} else {
344	8x	grp$df[, variables$strat, drop = FALSE]
345		}
346
347	46x	result <- h_odds_ratio_df(
348	46x	rsp = grp$df[[variables$rsp]],
349	46x	arm = grp$df[[variables$arm]],
350	46x	strata_data = grp_strata_data,
351	46x	conf_level = conf_level,
352	46x	method = method
353		)
354	46x	result_labels <- grp$df_labels[rep(1, times = nrow(result)), ]
355	46x	cbind(result, result_labels)
356		})
357
358	11x	result_subgroups <- do.call(rbind, args = c(l_result, make.row.names = FALSE))
359	11x	result_subgroups$row_type <- "analysis"
360
361	11x	rbind(
362	11x	result_all,
363	11x	result_subgroups
364		)
365		}
366		}

1		#' @include summarize_variables.R
2		NULL
3
4		#' Compare Variables Between Groups
5		#'
6		#' @description `r lifecycle::badge("stable")`
7		#'
8		#' We use the new S3 generic function [s_compare()] to implement comparisons for
9		#' different `x` objects. This is used as Statistics Function in combination
10		#' with the new Analyze Function [compare_vars()].
11		#'
12		#' @seealso Relevant constructor function [create_afun_compare()].
13		#'
14		#' @name compare_variables
15		#'
16		NULL
17
18		#' @inheritParams argument_convention
19		#' @describeIn compare_variables `s_compare` is a S3 generic function to produce
20		#' an object description and comparison versus the reference column in the form
21		#' of p-values.
22		#' @seealso [s_summary()] which is used internally for the summary part per column.
23		#'
24		#' @export
25		#'
26		s_compare <- function(x,
27		.ref_group,
28		.in_ref_col,
29		...) {
30	9x	UseMethod("s_compare", x)
31		}
32
33		#' @describeIn compare_variables Method for numeric class. This uses the standard t-test
34		#' to calculate the p-value.
35		#' @return If `x` is of class `numeric`, returns a list with named items:
36		#' - all items from [s_summary.numeric()].
37		#' - `pval`: the p-value.
38		#' @method s_compare numeric
39		#'
40		#' @export
41		#'
42		#' @examples
43		#' # `s_compare.numeric`
44		#'
45		#' ## Usual case where both this and the reference group vector have more than 1 value.
46		#' s_compare(rnorm(10, 5, 1), .ref_group = rnorm(5, -5, 1), .in_ref_col = FALSE)
47		#'
48		#' ## If one group has not more than 1 value, then p-value is not calculated.
49		#' s_compare(rnorm(10, 5, 1), .ref_group = 1, .in_ref_col = FALSE)
50		#'
51		#' ## Empty numeric does not fail, it returns NA-filled items and no p-value.
52		#' s_compare(numeric(), .ref_group = numeric(), .in_ref_col = FALSE)
53		s_compare.numeric <- function(x,
54		.ref_group,
55		.in_ref_col,
56		...) {
57	2x	checkmate::assert_numeric(x)
58	2x	checkmate::assert_numeric(.ref_group)
59	2x	checkmate::assert_flag(.in_ref_col)
60
61	2x	y <- s_summary.numeric(x = x, ...)
62
63	2x	y$pval <- if (!.in_ref_col && n_available(x) > 1 && n_available(.ref_group) > 1) {
64	1x	stats::t.test(x, .ref_group)$p.value
65		} else {
66	1x	character()
67		}
68
69	2x	y
70		}
71
72		#' @describeIn compare_variables Method for factor class. This uses the chi-squared test
73		#' to calculate the p-value. Note that the `denom` for factor proportions can only be `n` here
74		#' since the usage is for comparing proportions between columns.
75		#' Therefore a row-based proportion would not make sense. Also proportion based on `N_col` would
76		#' be difficult since for the chi-squared test statistic we use the counts. Therefore
77		#' missing values should be accounted for explicitly as factor levels.
78		#' @param denom (`string`)\cr choice of denominator for factor proportions,
79		#' can only be `n` (number of values in this row and column intersection).
80		#' @return If `x` is of class `factor` or converted from `character`, returns a list with named items:
81		#' - all items from [s_summary.factor()].
82		#' - `pval`: the p-value.
83		#' @method s_compare factor
84		#'
85		#' @export
86		#'
87		#' @examples
88		#' # `s_compare.factor`
89		#'
90		#' ## Basic usage:
91		#' x <- factor(c("a", "a", "b", "c", "a"))
92		#' y <- factor(c("a", "b", "c"))
93		#' s_compare(x = x, .ref_group = y, .in_ref_col = FALSE)
94		#'
95		#' ## Management of NA values.
96		#' x <- explicit_na(factor(c("a", "a", "b", "c", "a", NA, NA)))
97		#' y <- explicit_na(factor(c("a", "b", "c", NA)))
98		#' s_compare(x = x, .ref_group = y, .in_ref_col = FALSE, na.rm = TRUE)
99		#' s_compare(x = x, .ref_group = y, .in_ref_col = FALSE, na.rm = FALSE)
100		s_compare.factor <- function(x,
101		.ref_group,
102		.in_ref_col,
103		denom = "n",
104		na.rm = TRUE, # nolint
105		na_level = "<Missing>",
106		...) {
107	3x	checkmate::assert_flag(.in_ref_col)
108	3x	assert_valid_factor(x, any.missing = FALSE)
109	3x	assert_valid_factor(.ref_group, any.missing = FALSE)
110	3x	denom <- match.arg(denom)
111
112	3x	y <- s_summary.factor(
113	3x	x = x,
114	3x	denom = denom,
115	3x	na.rm = na.rm,
116	3x	na_level = na_level,
117		...
118		)
119
120	3x	if (na.rm) {
121	3x	x <- fct_discard(x, na_level)
122	3x	.ref_group <- fct_discard(.ref_group, na_level)
123		}
124
125	3x	checkmate::assert_factor(x, levels = levels(.ref_group), min.levels = 2)
126
127	3x	y$pval <- if (!.in_ref_col && length(x) > 0 && length(.ref_group) > 0) {
128	3x	tab <- rbind(table(x), table(.ref_group))
129	3x	res <- suppressWarnings(stats::chisq.test(tab))
130	3x	res$p.value
131		} else {
132	!	character()
133		}
134
135	3x	y
136		}
137
138		#' @describeIn compare_variables Method for character class. This makes an automatic
139		#' conversion to factor (with a warning) and then forwards to the method for factors.
140		#' @param verbose defaults to `TRUE`. It prints out warnings and messages. It is mainly used
141		#' to print out information about factor casting.
142		#' @note Automatic conversion of character to factor does not guarantee that the table
143		#' can be generated correctly. In particular for sparse tables this very likely can fail.
144		#' It is therefore better to always pre-process the dataset such that factors are manually
145		#' created from character variables before passing the dataset to [rtables::build_table()].
146		#' @method s_compare character
147		#'
148		#' @examples
149		#' # `s_compare.character`
150		#'
151		#' ## Basic usage:
152		#' x <- c("a", "a", "b", "c", "a")
153		#' y <- c("a", "b", "c")
154		#' s_compare(x, .ref_group = y, .in_ref_col = FALSE, .var = "x", verbose = FALSE)
155		#'
156		#' ## Note that missing values handling can make a large difference:
157		#' x <- c("a", "a", "b", "c", "a", NA)
158		#' y <- c("a", "b", "c", rep(NA, 20))
159		#' s_compare(x,
160		#' .ref_group = y, .in_ref_col = FALSE,
161		#' .var = "x", verbose = FALSE
162		#' )
163		#' s_compare(x,
164		#' .ref_group = y, .in_ref_col = FALSE, .var = "x",
165		#' na.rm = FALSE, verbose = FALSE
166		#' )
167		#'
168		#' @export
169		s_compare.character <- function(x,
170		.ref_group,
171		.in_ref_col,
172		denom = "n",
173		na.rm = TRUE, # nolint
174		na_level = "<Missing>",
175		.var,
176		verbose = TRUE,
177		...) {
178	1x	x <- as_factor_keep_attributes(x, x_name = .var, na_level = na_level, verbose = verbose)
179	1x	.ref_group <- as_factor_keep_attributes(.ref_group, x_name = .var, na_level = na_level, verbose = verbose)
180	1x	s_compare(
181	1x	x = x,
182	1x	.ref_group = .ref_group,
183	1x	.in_ref_col = .in_ref_col,
184	1x	denom = denom,
185	1x	na.rm = na.rm,
186	1x	na_level = na_level,
187		...
188		)
189		}
190
191		#' @describeIn compare_variables Method for logical class. A chi-squared test
192		#' is used. If missing values are not removed, then they are counted as `FALSE`.
193		#' @return If `x` is of class `logical`, returns a list with named items:
194		#' - all items from [s_summary.logical()].
195		#' - `pval`: the p-value.
196		#' @method s_compare logical
197		#'
198		#' @export
199		#'
200		#' @examples
201		#' # `s_compare.logical`
202		#'
203		#' ## Basic usage:
204		#' x <- c(TRUE, FALSE, TRUE, TRUE)
205		#' y <- c(FALSE, FALSE, TRUE)
206		#' s_compare(x, .ref_group = y, .in_ref_col = FALSE)
207		#'
208		#' ## Management of NA values.
209		#' x <- c(NA, TRUE, FALSE)
210		#' y <- c(NA, NA, NA, NA, FALSE)
211		#' s_compare(x, .ref_group = y, .in_ref_col = FALSE, na.rm = TRUE)
212		#' s_compare(x, .ref_group = y, .in_ref_col = FALSE, na.rm = FALSE)
213		s_compare.logical <- function(x,
214		.ref_group,
215		.in_ref_col,
216		na.rm = TRUE, # nolint
217		denom = "n",
218		...) {
219	3x	denom <- match.arg(denom)
220
221	3x	y <- s_summary.logical(
222	3x	x = x,
223	3x	na.rm = na.rm,
224	3x	denom = denom,
225		...
226		)
227
228	3x	if (na.rm) {
229	2x	x <- stats::na.omit(x)
230	2x	.ref_group <- stats::na.omit(.ref_group)
231		} else {
232	1x	x[is.na(x)] <- FALSE
233	1x	.ref_group[is.na(.ref_group)] <- FALSE
234		}
235
236	3x	y$pval <- if (!.in_ref_col && length(x) > 0 && length(.ref_group) > 0) {
237	3x	x <- factor(x, levels = c(TRUE, FALSE))
238	3x	.ref_group <- factor(.ref_group, levels = c(TRUE, FALSE))
239	3x	tbl <- rbind(table(x), table(.ref_group))
240	3x	suppressWarnings(prop_chisq(tbl))
241		} else {
242	!	character()
243		}
244
245	3x	y
246		}
247
248		#' @describeIn compare_variables S3 generic Formatted Analysis function to produce
249		#' an object description and comparison versus the reference column in the form
250		#' of p-values. It is used as `afun` in [rtables::analyze()].
251		#'
252		#' @export
253		#'
254		a_compare <- function(x,
255		.ref_group,
256		.in_ref_col,
257		...,
258		.var) {
259	!	UseMethod("a_compare", x)
260		}
261
262		#' @describeIn compare_variables Formatted Analysis function method for `numeric`.
263		#' @export
264		#'
265		#' @examples
266		#' # `a_compare.numeric`
267		#' a_compare(
268		#' rnorm(10, 5, 1),
269		#' .ref_group = rnorm(20, -5, 1),
270		#' .in_ref_col = FALSE,
271		#' .var = "bla"
272		#' )
273		a_compare.numeric <- make_afun(
274		s_compare.numeric,
275		.formats = c(
276		.a_summary_numeric_formats,
277		pval = "x.xxxx \| (<0.0001)"
278		),
279		.labels = c(
280		.a_summary_numeric_labels,
281		pval = "p-value (t-test)"
282		),
283		.null_ref_cells = FALSE
284		)
285
286		.a_compare_counts_formats <- c(
287		.a_summary_counts_formats,
288		pval = "x.xxxx \| (<0.0001)"
289		)
290
291		.a_compare_counts_labels <- c(
292		pval = "p-value (chi-squared test)"
293		)
294
295		#' @describeIn compare_variables Formatted Analysis function method for `factor`.
296		#' @export
297		#'
298		#' @examples
299		#' # `a_compare.factor`
300		#' # We need to ungroup `count` and `count_fraction` first so that the `rtables` formatting
301		#' # functions can be applied correctly.
302		#' afun <- make_afun(
303		#' getS3method("a_compare", "factor"),
304		#' .ungroup_stats = c("count", "count_fraction")
305		#' )
306		#' x <- factor(c("a", "a", "b", "c", "a"))
307		#' y <- factor(c("a", "a", "b", "c"))
308		#' afun(x, .ref_group = y, .in_ref_col = FALSE)
309		a_compare.factor <- make_afun(
310		s_compare.factor,
311		.formats = .a_compare_counts_formats,
312		.labels = .a_compare_counts_labels,
313		.null_ref_cells = FALSE
314		)
315
316		#' @describeIn compare_variables Formatted Analysis function method for `character`.
317		#' @export
318		#'
319		#' @examples
320		#' # `a_compare.character`
321		#' afun <- make_afun(
322		#' getS3method("a_compare", "character"),
323		#' .ungroup_stats = c("count", "count_fraction")
324		#' )
325		#' x <- c("A", "B", "A", "C")
326		#' y <- c("B", "A", "C")
327		#' afun(x, .ref_group = y, .in_ref_col = FALSE, .var = "x", verbose = FALSE)
328		a_compare.character <- make_afun(
329		s_compare.character,
330		.formats = .a_compare_counts_formats,
331		.labels = .a_compare_counts_labels,
332		.null_ref_cells = FALSE
333		)
334
335		#' @describeIn compare_variables Formatted Analysis function method for `logical`.
336		#' @export
337		#'
338		#' @examples
339		#' # `a_compare.logical`
340		#' afun <- make_afun(
341		#' getS3method("a_compare", "logical")
342		#' )
343		#' x <- c(TRUE, FALSE, FALSE, TRUE, TRUE)
344		#' y <- c(TRUE, FALSE)
345		#' afun(x, .ref_group = y, .in_ref_col = FALSE)
346		a_compare.logical <- make_afun(
347		s_compare.logical,
348		.formats = .a_compare_counts_formats,
349		.labels = .a_compare_counts_labels,
350		.null_ref_cells = FALSE
351		)
352
353		#' Constructor Function for [compare_vars()]
354		#'
355		#' @description `r lifecycle::badge("stable")` Constructor function which creates a combined Formatted
356		#' Analysis function for use in layout creating functions [compare_vars()].
357		#'
358		#' @note Since [a_compare()] is generic and we want customization of the formatting arguments
359		#' via [rtables::make_afun()], we need to create another temporary generic function, with
360		#' corresponding customized methods. Then in order for the methods to be found,
361		#' we need to wrap them in a combined `afun`. Since this is required by two layout creating
362		#' functions (and possibly others in the future), we provide a constructor that does this:
363		#' [create_afun_compare()].
364		#' @export
365		#' @inheritParams argument_convention
366		#' @seealso [compare_variables]
367		#'
368		#' @examples
369		#' # `create_afun_compare()` to create combined `afun`
370		#'
371		#' afun <- create_afun_compare(
372		#' .stats = c("n", "count_fraction", "mean_sd", "pval"),
373		#' .indent_mods = c(pval = 1L)
374		#' )
375		#'
376		#' lyt <- basic_table() %>%
377		#' split_cols_by("ARMCD", ref_group = "ARM A") %>%
378		#' analyze(
379		#' "AGE",
380		#' afun = afun,
381		#' show_labels = "visible"
382		#' )
383		#' build_table(lyt, df = tern_ex_adsl)
384		#'
385		#' lyt <- basic_table() %>%
386		#' split_cols_by("ARMCD", ref_group = "ARM A") %>%
387		#' analyze(
388		#' "SEX",
389		#' afun = afun,
390		#' show_labels = "visible"
391		#' )
392		#' build_table(lyt, df = tern_ex_adsl)
393		create_afun_compare <- function(.stats = NULL,
394		.formats = NULL,
395		.labels = NULL,
396		.indent_mods = NULL) {
397	2x	function(x,
398	2x	.ref_group,
399	2x	.in_ref_col,
400		...,
401	2x	.var) {
402	12x	afun <- function(x, ...) {
403	12x	UseMethod("afun", x)
404		}
405
406	12x	numeric_stats <- afun_selected_stats(
407	12x	.stats,
408	12x	all_stats = c(names(.a_summary_numeric_formats), "pval")
409		)
410	12x	afun.numeric <- make_afun( # nolint
411	12x	a_compare.numeric,
412	12x	.stats = numeric_stats,
413	12x	.formats = extract_by_name(.formats, numeric_stats),
414	12x	.labels = extract_by_name(.labels, numeric_stats),
415	12x	.indent_mods = extract_by_name(.indent_mods, numeric_stats),
416	12x	.null_ref_cells = FALSE
417		)
418
419	12x	factor_stats <- afun_selected_stats(
420	12x	.stats,
421	12x	all_stats = names(.a_compare_counts_formats)
422		)
423	12x	ungroup_stats <- afun_selected_stats(.stats, c("count", "count_fraction"))
424	12x	afun.factor <- make_afun( # nolint
425	12x	a_compare.factor,
426	12x	.stats = factor_stats,
427	12x	.formats = extract_by_name(.formats, factor_stats),
428	12x	.labels = extract_by_name(.labels, factor_stats),
429	12x	.indent_mods = extract_by_name(.indent_mods, factor_stats),
430	12x	.ungroup_stats = ungroup_stats,
431	12x	.null_ref_cells = FALSE
432		)
433
434	12x	afun.character <- make_afun( # nolint
435	12x	a_compare.character,
436	12x	.stats = factor_stats,
437	12x	.formats = extract_by_name(.formats, factor_stats),
438	12x	.labels = extract_by_name(.labels, factor_stats),
439	12x	.indent_mods = extract_by_name(.indent_mods, factor_stats),
440	12x	.ungroup_stats = ungroup_stats,
441	12x	.null_ref_cells = FALSE
442		)
443
444	12x	afun.logical <- make_afun( # nolint
445	12x	a_compare.logical,
446	12x	.stats = factor_stats,
447	12x	.formats = extract_by_name(.formats, factor_stats),
448	12x	.labels = extract_by_name(.labels, factor_stats),
449	12x	.indent_mods = extract_by_name(.indent_mods, factor_stats),
450	12x	.null_ref_cells = FALSE
451		)
452
453	12x	afun(
454	12x	x = x,
455	12x	.ref_group = .ref_group,
456	12x	.in_ref_col = .in_ref_col,
457		...,
458	12x	.var = .var
459		)
460		}
461		}
462
463		#' @describeIn compare_variables Analyze Function to add a comparison of variables to
464		#' `rtables` pipelines. The column split needs to have the reference group defined
465		#' via `ref_group` so that the comparison is well defined.
466		#' The ellipsis (`...`) conveys arguments to [s_compare()].
467		#' When factor variables contains `NA`, it is expected that `NA`
468		#' have been conveyed to `na_level` appropriately beforehand with
469		#' [df_explicit_na()].
470		#' @inheritParams rtables::analyze
471		#' @param ... arguments passed to `s_compare()`.
472		#'
473		#' @template formatting_arguments
474		#' @export
475		#'
476		#' @examples
477		#' # `compare_vars()` in `rtables` pipelines
478		#'
479		#' ## Default output within a `rtables` pipeline.
480		#' lyt <- basic_table() %>%
481		#' split_cols_by("ARMCD", ref_group = "ARM B") %>%
482		#' compare_vars(c("AGE", "SEX"))
483		#' build_table(lyt, tern_ex_adsl)
484		#'
485		#' ## Select and format statistics output.
486		#' lyt <- basic_table() %>%
487		#' split_cols_by("ARMCD", ref_group = "ARM C") %>%
488		#' compare_vars(
489		#' vars = "AGE",
490		#' .stats = c("mean_sd", "pval"),
491		#' .formats = c(mean_sd = "xx.x, xx.x"),
492		#' .labels = c(mean_sd = "Mean, SD")
493		#' )
494		#' build_table(lyt, df = tern_ex_adsl)
495		compare_vars <- function(lyt,
496		vars,
497		var_labels = vars,
498		nested = TRUE,
499		...,
500		show_labels = "default",
501		table_names = vars,
502		.stats = c("n", "mean_sd", "count_fraction", "pval"),
503		.formats = NULL,
504		.labels = NULL,
505		.indent_mods = NULL) {
506	2x	afun <- create_afun_compare(.stats, .formats, .labels, .indent_mods)
507
508	2x	analyze(
509	2x	lyt = lyt,
510	2x	vars = vars,
511	2x	var_labels = var_labels,
512	2x	afun = afun,
513	2x	nested = nested,
514	2x	extra_args = list(...),
515	2x	inclNAs = TRUE,
516	2x	show_labels = show_labels,
517	2x	table_names = table_names
518		)
519		}

1		#' Line plot with the optional table
2		#'
3		#' @description `r lifecycle::badge("stable")`
4		#'
5		#' Line plot with the optional table.
6		#'
7		#' @param df (`data.frame`)\cr data set containing all analysis variables.
8		#' @param alt_counts_df (`data.frame` or `NULL`)\cr data set that will be used (only) to counts objects in strata.
9		#' @param variables (named `character` vector) of variable names in `df` data set. Details are:
10		#' * `x` (`character`)\cr name of x-axis variable.
11		#' * `y` (`character`)\cr name of y-axis variable.
12		#' * `strata` (`character`)\cr name of grouping variable, i.e. treatment arm. Can be `NA` to indicate lack of groups.
13		#' * `paramcd` (`character`)\cr name of the variable for parameter's code. Used for y-axis label and plot's subtitle.
14		#' Can be `NA` if paramcd is not to be added to the y-axis label or subtitle.
15		#' * `y_unit` (`character`)\cr name of variable with units of `y`. Used for y-axis label and plot's subtitle.
16		#' Can be `NA` if y unit is not to be added to the y-axis label or subtitle.
17		#' @param mid (`character` or `NULL`)\cr names of the statistics that will be plotted as midpoints.
18		#' All the statistics indicated in `mid` variable must be present in the object returned by `sfun`,
19		#' and be of a `double` or `numeric` type vector of length one.
20		#' @param interval (`character` or `NULL`)\cr names of the statistics that will be plotted as intervals.
21		#' All the statistics indicated in `interval` variable must be present in the object returned by `sfun`,
22		#' and be of a `double` or `numeric` type vector of length two.
23		#' @param whiskers (`character`)\cr names of the interval whiskers that will be plotted. Must match the `names`
24		#' attribute of the `interval` element in the list returned by `sfun`. It is possible to specify one whisker only,
25		#' lower or upper.
26		#' @param table (`character` or `NULL`)\cr names of the statistics that will be displayed in the table below the plot.
27		#' All the statistics indicated in `table` variable must be present in the object returned by `sfun`.
28		#' @param sfun (`closure`)\cr the function to compute the values of required statistics. It must return a named `list`
29		#' with atomic vectors. The names of the `list` elements refer to the names of the statistics and are used by `mid`,
30		#' `interval`, `table`. It must be able to accept as input a vector with data for which statistics are computed.
31		#' @param ... optional arguments to `sfun`.
32		#' @param mid_type (`character`)\cr controls the type of the `mid` plot, it can be point (`p`), line (`l`),
33		#' or point and line (`pl`).
34		#' @param mid_point_size (`integer` or `double`)\cr controls the font size of the point for `mid` plot.
35		#' @param position (`character` or `call`)\cr geom element position adjustment, either as a string, or the result of
36		#' a call to a position adjustment function.
37		#' @param legend_title (`character` string)\cr legend title.
38		#' @param legend_position (`character`)\cr the position of the plot legend (`none`, `left`, `right`, `bottom`, `top`,
39		#' or two-element numeric vector).
40		#' @param ggtheme (`theme`)\cr a graphical theme as provided by `ggplot2` to control styling of the plot.
41		#' @param y_lab (`character`)\cr y-axis label. If equal to `NULL`, then no label will be added.
42		#' @param y_lab_add_paramcd (`logical`)\cr should paramcd, i.e. `unique(df[[variables["paramcd"]]])` be added to the
43		#' y-axis label `y_lab`?
44		#' @param y_lab_add_unit (`logical`)\cr should y unit, i.e. `unique(df[[variables["y_unit"]]])` be added to the y-axis
45		#' label `y_lab`?
46		#' @param title (`character`)\cr plot title.
47		#' @param subtitle (`character`)\cr plot subtitle.
48		#' @param subtitle_add_paramcd (`logical`)\cr should paramcd, i.e. `unique(df[[variables["paramcd"]]])` be added to
49		#' the plot's subtitle `subtitle`?
50		#' @param subtitle_add_unit (`logical`)\cr should y unit, i.e. `unique(df[[variables["y_unit"]]])` be added to the
51		#' plot's subtitle `subtitle`?
52		#' @param caption (`character`)\cr optional caption below the plot.
53		#' @param table_format (named `character` or `NULL`)\cr format patterns for descriptive statistics used in the
54		#' (optional) table appended to the plot. It is passed directly to the `h_format_row` function through the `format`
55		#' parameter. Names of `table_format` must match the names of statistics returned by `sfun` function.
56		#' @param table_labels (named `character` or `NULL`)\cr labels for descriptive statistics used in the (optional) table
57		#' appended to the plot. Names of `table_labels` must match the names of statistics returned by `sfun` function.
58		#' @param table_font_size (`integer` or `double`)\cr controls the font size of values in the table.
59		#' @param newpage (`logical`)\cr should plot be drawn on new page?
60		#' @param col (`character`)\cr colors.
61		#'
62		#' @author Wojciech Wojciak wojciech.wojciak@contractors.roche.com
63		#'
64		#' @return \code{ggplot}
65		#'
66		#' @export
67		#'
68		#' @examples
69		#' library(nestcolor)
70		#'
71		#' adsl <- tern_ex_adsl
72		#' adlb <- tern_ex_adlb %>% dplyr::filter(ANL01FL == "Y", PARAMCD == "ALT", AVISIT != "SCREENING")
73		#' adlb$AVISIT <- droplevels(adlb$AVISIT)
74		#' adlb <- dplyr::mutate(adlb, AVISIT = forcats::fct_reorder(AVISIT, AVISITN, min))
75		#'
76		#' # Mean with CI
77		#' g_lineplot(adlb, adsl, subtitle = "Laboratory Test:")
78		#'
79		#' # Mean with CI, no stratification
80		#' g_lineplot(adlb, variables = control_lineplot_vars(strata = NA))
81		#'
82		#' # Mean, upper whisker of CI, no strata counts N
83		#' g_lineplot(
84		#' adlb,
85		#' whiskers = "mean_ci_upr",
86		#' title = "Plot of Mean and Upper 95% Confidence Limit by Visit"
87		#' )
88		#'
89		#' # Median with CI
90		#' g_lineplot(
91		#' adlb,
92		#' adsl,
93		#' mid = "median",
94		#' interval = "median_ci",
95		#' whiskers = c("median_ci_lwr", "median_ci_upr"),
96		#' title = "Plot of Median and 95% Confidence Limits by Visit"
97		#' )
98		#'
99		#' # Mean, +/- SD
100		#' g_lineplot(adlb, adsl,
101		#' interval = "mean_sdi",
102		#' whiskers = c("mean_sdi_lwr", "mean_sdi_upr"),
103		#' title = "Plot of Median +/- SD by Visit"
104		#' )
105		#'
106		#' # Mean with CI plot with stats table
107		#' g_lineplot(adlb, adsl, table = c("n", "mean", "mean_ci"))
108		#'
109		#' # Mean with CI, table and customized confidence level
110		#' g_lineplot(
111		#' adlb,
112		#' adsl,
113		#' table = c("n", "mean", "mean_ci"),
114		#' control = control_summarize_vars(conf_level = 0.80),
115		#' title = "Plot of Mean and 80% Confidence Limits by Visit"
116		#' )
117		#'
118		#' # Mean with CI, table, filtered data
119		#' adlb_f <- dplyr::filter(adlb, ARMCD != "ARM A" \| AVISIT == "BASELINE")
120		#' g_lineplot(adlb_f, table = c("n", "mean"))
121		g_lineplot <- function(df, # nolint
122		alt_counts_df = NULL,
123		variables = control_lineplot_vars(),
124		mid = "mean",
125		interval = "mean_ci",
126		whiskers = c("mean_ci_lwr", "mean_ci_upr"),
127		table = NULL,
128		sfun = tern::s_summary,
129		...,
130		mid_type = "pl",
131		mid_point_size = 2,
132		position = ggplot2::position_dodge(width = 0.4),
133		legend_title = NULL,
134		legend_position = "bottom",
135		ggtheme = nestcolor::theme_nest(),
136		y_lab = NULL,
137		y_lab_add_paramcd = TRUE,
138		y_lab_add_unit = TRUE,
139		title = "Plot of Mean and 95% Confidence Limits by Visit",
140		subtitle = "",
141		subtitle_add_paramcd = TRUE,
142		subtitle_add_unit = TRUE,
143		caption = NULL,
144		table_format = summary_formats(),
145		table_labels = summary_labels(),
146		table_font_size = 3,
147		newpage = TRUE,
148		col = NULL) {
149	2x	checkmate::assert_character(variables, any.missing = TRUE)
150	2x	checkmate::assert_character(mid, null.ok = TRUE)
151	2x	checkmate::assert_character(interval, null.ok = TRUE)
152	2x	checkmate::assert_character(col, null.ok = TRUE)
153
154	2x	checkmate::assert_string(title, null.ok = TRUE)
155	2x	checkmate::assert_string(subtitle, null.ok = TRUE)
156
157	2x	if (is.character(interval)) {
158	2x	checkmate::assert_vector(whiskers, min.len = 0, max.len = 2)
159		}
160
161	2x	if (length(whiskers) == 1) {
162	!	checkmate::assert_character(mid)
163		}
164
165	2x	if (is.character(mid)) {
166	2x	checkmate::assert_scalar(mid_type)
167	2x	checkmate::assert_subset(mid_type, c("pl", "p", "l"))
168		}
169
170	2x	x <- variables[["x"]]
171	2x	y <- variables[["y"]]
172	2x	paramcd <- variables["paramcd"] # NA if paramcd == NA or it is not in variables
173	2x	y_unit <- variables["y_unit"] # NA if y_unit == NA or it is not in variables
174	2x	if (is.na(variables["strata"])) {
175	!	strata <- NULL # NULL if strata == NA or it is not in variables
176		} else {
177	2x	strata <- variables[["strata"]]
178		}
179	2x	checkmate::assert_flag(y_lab_add_paramcd, null.ok = TRUE)
180	2x	checkmate::assert_flag(subtitle_add_paramcd, null.ok = TRUE)
181	2x	if ((!is.null(y_lab) && y_lab_add_paramcd) \|\| (!is.null(subtitle) && subtitle_add_paramcd)) {
182	2x	checkmate::assert_false(is.na(paramcd))
183	2x	checkmate::assert_scalar(unique(df[[paramcd]]))
184		}
185
186	2x	checkmate::assert_flag(y_lab_add_unit, null.ok = TRUE)
187	2x	checkmate::assert_flag(subtitle_add_unit, null.ok = TRUE)
188	2x	if ((!is.null(y_lab) && y_lab_add_unit) \|\| (!is.null(subtitle) && subtitle_add_unit)) {
189	2x	checkmate::assert_false(is.na(y_unit))
190	2x	checkmate::assert_scalar(unique(df[[y_unit]]))
191		}
192
193	2x	if (!is.null(strata) && !is.null(alt_counts_df)) {
194	2x	checkmate::assert_set_equal(unique(alt_counts_df[[strata]]), unique(df[[strata]]))
195		}
196
197		####################################### \|
198		# ---- Compute required statistics ----
199		####################################### \|
200	2x	if (!is.null(strata)) {
201	2x	df_grp <- tidyr::expand(df, .data[[strata]], .data[[x]]) # expand based on levels of factors
202		} else {
203	!	df_grp <- tidyr::expand(df, NULL, .data[[x]])
204		}
205	2x	df_grp <- df_grp %>%
206	2x	dplyr::full_join(y = df[, c(strata, x, y)], by = c(strata, x), multiple = "all") %>%
207	2x	dplyr::group_by_at(c(strata, x))
208
209	2x	df_stats <- df_grp %>%
210	2x	dplyr::summarise(
211	2x	data.frame(t(do.call(c, unname(sfun(.data[[y]], ...)[c(mid, interval)])))),
212	2x	.groups = "drop"
213		)
214
215	2x	df_stats <- df_stats %>% dplyr::filter(!is.na(mid))
216
217		# add number of objects N in strata
218	2x	if (!is.null(strata) && !is.null(alt_counts_df)) {
219	2x	strata_N <- paste0(strata, "_N") # nolint
220
221	2x	df_N <- as.data.frame(table(alt_counts_df[[strata]], exclude = c(NA, NaN, Inf))) # nolint
222	2x	colnames(df_N) <- c(strata, "N") # nolint
223	2x	df_N[[strata_N]] <- paste0(df_N[[strata]], " (N = ", df_N$N, ")") # nolint
224
225		# strata_N should not be in clonames(df_stats)
226	2x	checkmate::assert_disjunct(strata_N, colnames(df_stats))
227
228	2x	df_stats <- merge(x = df_stats, y = df_N[, c(strata, strata_N)], by = strata)
229	!	} else if (!is.null(strata)) {
230	!	strata_N <- strata # nolint
231		} else {
232	!	strata_N <- NULL # nolint
233		}
234
235		############################################### \|
236		# ---- Prepare certain plot's properties. ----
237		############################################### \|
238		# legend title
239	2x	if (is.null(legend_title) && !is.null(strata) && legend_position != "none") {
240	2x	legend_title <- attr(df[[strata]], "label")
241		}
242
243		# y label
244	2x	if (!is.null(y_lab)) {
245	1x	if (y_lab_add_paramcd) {
246	1x	y_lab <- paste(y_lab, unique(df[[paramcd]]))
247		}
248
249	1x	if (y_lab_add_unit) {
250	1x	y_lab <- paste0(y_lab, " (", unique(df[[y_unit]]), ")")
251		}
252
253	1x	y_lab <- trimws(y_lab)
254		}
255
256		# subtitle
257	2x	if (!is.null(subtitle)) {
258	2x	if (subtitle_add_paramcd) {
259	2x	subtitle <- paste(subtitle, unique(df[[paramcd]]))
260		}
261
262	2x	if (subtitle_add_unit) {
263	2x	subtitle <- paste0(subtitle, " (", unique(df[[y_unit]]), ")")
264		}
265
266	2x	subtitle <- trimws(subtitle)
267		}
268
269		############################### \|
270		# ---- Build plot object. ----
271		############################### \|
272	2x	p <- ggplot2::ggplot(
273	2x	data = df_stats,
274	2x	mapping = ggplot2::aes(
275	2x	x = .data[[x]], y = .data[[mid]],
276	2x	color = if (is.null(strata_N)) NULL else .data[[strata_N]],
277	2x	shape = if (is.null(strata_N)) NULL else .data[[strata_N]],
278	2x	lty = if (is.null(strata_N)) NULL else .data[[strata_N]],
279	2x	group = if (is.null(strata_N)) NULL else .data[[strata_N]]
280		)
281		)
282
283	2x	if (!is.null(mid)) {
284		# points
285	2x	if (grepl("p", mid_type, fixed = TRUE)) {
286	2x	p <- p + ggplot2::geom_point(position = position, size = mid_point_size, na.rm = TRUE)
287		}
288
289		# lines
290		# further conditions in if are to ensure that not all of the groups consist of only one observation
291	2x	if (grepl("l", mid_type, fixed = TRUE) &&
292	2x	!is.null(strata) &&
293	2x	!all(dplyr::summarise(df_grp, count_n = dplyr::n())[["count_n"]] == 1L)) {
294	2x	p <- p + ggplot2::geom_line(position = position, na.rm = TRUE)
295		}
296		}
297
298		# interval
299	2x	if (!is.null(interval)) {
300	2x	p <- p +
301	2x	ggplot2::geom_errorbar(
302	2x	ggplot2::aes(ymin = .data[[whiskers[1]]], ymax = .data[[whiskers[max(1, length(whiskers))]]]),
303	2x	width = 0.45,
304	2x	position = position
305		)
306
307	2x	if (length(whiskers) == 1) { # lwr or upr only; mid is then required
308		# workaround as geom_errorbar does not provide single-direction whiskers
309	!	p <- p +
310	!	ggplot2::geom_linerange(
311	!	data = df_stats[!is.na(df_stats[[whiskers]]), ], # as na.rm =TRUE does not suppress warnings
312	!	ggplot2::aes(ymin = .data[[mid]], ymax = .data[[whiskers]]),
313	!	position = position,
314	!	na.rm = TRUE,
315	!	show.legend = FALSE
316		)
317		}
318		}
319
320	2x	p <- p +
321	2x	ggplot2::scale_y_continuous(labels = scales::comma, expand = ggplot2::expansion(c(0.25, .25))) +
322	2x	ggplot2::labs(
323	2x	title = title,
324	2x	subtitle = subtitle,
325	2x	caption = caption,
326	2x	color = legend_title,
327	2x	lty = legend_title,
328	2x	shape = legend_title,
329	2x	x = attr(df[[x]], "label"),
330	2x	y = y_lab
331		)
332
333	2x	if (!is.null(col)) {
334	!	p <- p +
335	!	ggplot2::scale_color_manual(values = col)
336		}
337
338	2x	if (!is.null(ggtheme)) {
339	2x	p <- p + ggtheme
340		} else {
341	!	p <- p +
342	!	ggplot2::theme_bw() +
343	!	ggplot2::theme(
344	!	legend.key.width = grid::unit(1, "cm"),
345	!	legend.position = legend_position,
346	!	legend.direction = ifelse(
347	!	legend_position %in% c("top", "bottom"),
348	!	"horizontal",
349	!	"vertical"
350		)
351		)
352		}
353
354		############################################################# \|
355		# ---- Optionally, add table to the bottom of the plot. ----
356		############################################################# \|
357	2x	if (!is.null(table)) {
358	1x	df_stats_table <- df_grp %>%
359	1x	dplyr::summarise(
360	1x	h_format_row(
361	1x	x = sfun(.data[[y]], ...)[table],
362	1x	format = table_format,
363	1x	labels = table_labels
364		),
365	1x	.groups = "drop"
366		)
367
368	1x	stats_lev <- rev(setdiff(colnames(df_stats_table), c(strata, x)))
369
370	1x	df_stats_table <- df_stats_table %>%
371	1x	tidyr::pivot_longer(
372	1x	cols = -dplyr::all_of(c(strata, x)),
373	1x	names_to = "stat",
374	1x	values_to = "value",
375	1x	names_ptypes = list(stat = factor(levels = stats_lev))
376		)
377
378	1x	tbl <- ggplot2::ggplot(
379	1x	df_stats_table,
380	1x	ggplot2::aes(x = .data[[x]], y = .data[["stat"]], label = .data[["value"]])
381		) +
382	1x	ggplot2::geom_text(size = table_font_size) +
383	1x	ggplot2::theme_bw() +
384	1x	ggplot2::theme(
385	1x	panel.border = ggplot2::element_blank(),
386	1x	panel.grid.major = ggplot2::element_blank(),
387	1x	panel.grid.minor = ggplot2::element_blank(),
388	1x	axis.ticks = ggplot2::element_blank(),
389	1x	axis.title = ggplot2::element_blank(),
390	1x	axis.text.x = ggplot2::element_blank(),
391	1x	axis.text.y = ggplot2::element_text(margin = ggplot2::margin(t = 0, r = 0, b = 0, l = 5)),
392	1x	strip.text = ggplot2::element_text(hjust = 0),
393	1x	strip.text.x = ggplot2::element_text(margin = ggplot2::margin(1.5, 0, 1.5, 0, "pt")),
394	1x	strip.background = ggplot2::element_rect(fill = "grey95", color = NA),
395	1x	legend.position = "none"
396		)
397
398	1x	if (!is.null(strata)) {
399	1x	tbl <- tbl + ggplot2::facet_wrap(facets = strata, ncol = 1)
400		}
401
402		# align plot and table
403	1x	cowplot::plot_grid(p, tbl, ncol = 1)
404		} else {
405	1x	p
406		}
407		}
408
409		#' Helper function to get the right formatting in the optional table in g_lineplot.
410		#'
411		#' @description `r lifecycle::badge("stable")`
412		#'
413		#' @param x (named `list`)\cr list of numerical values to be formatted and optionally labeled.
414		#' Elements of `x` must be `numeric` vectors.
415		#' @param format (named `character` or `NULL`)\cr
416		#' format patterns for `x`. Names of the `format` must match the names of `x`.
417		#' This parameter is passed directly to the `rtables::format_rcell`
418		#' function through the `format` parameter.
419		#' @param labels (named `character` or `NULL`)\cr
420		#' optional labels for `x`. Names of the `labels` must match the names of `x`.
421		#' When a label is not specified for an element of `x`,
422		#' then this function tries to use `label` or `names` (in this order) attribute of that element
423		#' (depending on which one exists and it is not `NULL` or `NA` or `NaN`).
424		#' If none of these attributes are attached to a given element of `x`,
425		#' then the label is automatically generated.
426		#'
427		#' @author Wojciech Wojciak wojciech.wojciak@contractors.roche.com
428		#'
429		#' @return 1-row \code{data.frame} object
430		#'
431		#' @examples
432		#'
433		#' mean_ci <- c(48, 51)
434		#' x <- list(mean = 50, mean_ci = mean_ci)
435		#' format <- c(mean = "xx.x", mean_ci = "(xx.xx, xx.xx)")
436		#' labels <- c(mean = "My Mean")
437		#' h_format_row(x, format, labels)
438		#'
439		#' attr(mean_ci, "label") <- "Mean 95% CI"
440		#' x <- list(mean = 50, mean_ci = mean_ci)
441		#' h_format_row(x, format, labels)
442		#'
443		#' @export
444		h_format_row <- function(x, format, labels = NULL) {
445		# cell: one row, one column data.frame
446	19x	format_cell <- function(x, format, label = NULL) {
447	56x	fc <- format_rcell(x = x, format = format)
448	56x	if (is.na(fc)) {
449	!	fc <- "NA"
450		}
451	56x	x_label <- attr(x, "label")
452	56x	if (!is.null(label) && !is.na(label)) {
453	37x	names(fc) <- label
454	19x	} else if (!is.null(x_label) && !is.na(x_label)) {
455	18x	names(fc) <- x_label
456	1x	} else if (length(x) == length(fc)) {
457	!	names(fc) <- names(x)
458		}
459	56x	as.data.frame(t(fc))
460		}
461
462	19x	row <- do.call(
463	19x	cbind,
464	19x	lapply(
465	19x	names(x), function(xn) format_cell(x[[xn]], format = format[xn], label = labels[xn])
466		)
467		)
468
469	19x	row
470		}
471
472		#' Control Function for g_lineplot Function
473		#'
474		#' @description `r lifecycle::badge("stable")`
475		#'
476		#' Default values for `variables` parameter in `g_lineplot` function.
477		#' A variable's default value can be overwritten for any variable.
478		#'
479		#' @param x (`character`)\cr x variable name.
480		#' @param y (`character`)\cr y variable name.
481		#' @param strata (`character` or `NA`)\cr strata variable name.
482		#' @param paramcd (`character` or `NA`)\cr paramcd variable name.
483		#' @param y_unit (`character` or `NA`)\cr y_unit variable name.
484		#'
485		#' @return A named character vector with names of variables.
486		#'
487		#' @author Wojciech Wojciak wojciech.wojciak@contractors.roche.com
488		#'
489		#' @export
490		#'
491		#' @examples
492		#' control_lineplot_vars()
493		#' control_lineplot_vars(strata = NA)
494		control_lineplot_vars <- function(x = "AVISIT", y = "AVAL", strata = "ARM", paramcd = "PARAMCD", y_unit = "AVALU") {
495	2x	checkmate::assert_string(x)
496	2x	checkmate::assert_string(y)
497	2x	checkmate::assert_string(strata, na.ok = TRUE)
498	2x	checkmate::assert_string(paramcd, na.ok = TRUE)
499	2x	checkmate::assert_string(y_unit, na.ok = TRUE)
500
501	2x	variables <- c(x = x, y = y, strata = strata, paramcd = paramcd, y_unit = y_unit)
502	2x	return(variables)
503		}

1		#' Proportion Difference
2		#'
3		#' @description `r lifecycle::badge("stable")`
4		#'
5		#' @inheritParams argument_convention
6		#'
7		#' @seealso [d_proportion_diff()]
8		#'
9		#' @name prop_diff
10		NULL
11
12		#' @describeIn prop_diff Statistics function estimating the difference
13		#' in terms of responder proportion.
14		#'
15		#' @inheritParams prop_diff_strat_nc
16		#' @param method (`string`)\cr the method used for the confidence interval estimation.
17		#'
18		#' @examples
19		#' # Summary
20		#'
21		#' ## "Mid" case: 4/4 respond in group A, 1/2 respond in group B.
22		#' nex <- 100 # Number of example rows
23		#' dta <- data.frame(
24		#' "rsp" = sample(c(TRUE, FALSE), nex, TRUE),
25		#' "grp" = sample(c("A", "B"), nex, TRUE),
26		#' "f1" = sample(c("a1", "a2"), nex, TRUE),
27		#' "f2" = sample(c("x", "y", "z"), nex, TRUE),
28		#' stringsAsFactors = TRUE
29		#' )
30		#'
31		#' s_proportion_diff(
32		#' df = subset(dta, grp == "A"),
33		#' .var = "rsp",
34		#' .ref_group = subset(dta, grp == "B"),
35		#' .in_ref_col = FALSE,
36		#' conf_level = 0.90,
37		#' method = "ha"
38		#' )
39		#'
40		#' # CMH example with strata
41		#' s_proportion_diff(
42		#' df = subset(dta, grp == "A"),
43		#' .var = "rsp",
44		#' .ref_group = subset(dta, grp == "B"),
45		#' .in_ref_col = FALSE,
46		#' variables = list(strata = c("f1", "f2")),
47		#' conf_level = 0.90,
48		#' method = "cmh"
49		#' )
50		#'
51		#' @export
52		s_proportion_diff <- function(df,
53		.var,
54		.ref_group,
55		.in_ref_col,
56		variables = list(strata = NULL),
57		conf_level = 0.95,
58		method = c(
59		"waldcc", "wald", "cmh",
60		"ha", "newcombe", "newcombecc",
61		"strat_newcombe", "strat_newcombecc"
62		),
63		weights_method = "cmh") {
64	2x	method <- match.arg(method)
65	2x	y <- list(diff = "", diff_ci = "")
66
67	2x	if (!.in_ref_col) {
68	2x	rsp <- c(.ref_group[[.var]], df[[.var]])
69	2x	grp <- factor(
70	2x	rep(
71	2x	c("ref", "Not-ref"),
72	2x	c(nrow(.ref_group), nrow(df))
73		),
74	2x	levels = c("ref", "Not-ref")
75		)
76
77	2x	if (!is.null(variables$strata)) {
78	1x	strata_colnames <- variables$strata
79	1x	checkmate::assert_character(strata_colnames, null.ok = FALSE)
80	1x	strata_vars <- stats::setNames(as.list(strata_colnames), strata_colnames)
81
82	1x	assert_df_with_variables(df, strata_vars)
83	1x	assert_df_with_variables(.ref_group, strata_vars)
84
85		# Merging interaction strata for reference group rows data and remaining
86	1x	strata <- c(
87	1x	interaction(.ref_group[strata_colnames]),
88	1x	interaction(df[strata_colnames])
89		)
90	1x	strata <- as.factor(strata)
91		}
92
93		# Defining the std way to calculate weights for strat_newcombe
94	2x	if (!is.null(variables$weights_method)) {
95	!	weights_method <- variables$weights_method
96		} else {
97	2x	weights_method <- "cmh"
98		}
99
100	2x	y <- switch(method,
101	2x	"wald" = prop_diff_wald(rsp, grp, conf_level, correct = FALSE),
102	2x	"waldcc" = prop_diff_wald(rsp, grp, conf_level, correct = TRUE),
103	2x	"ha" = prop_diff_ha(rsp, grp, conf_level),
104	2x	"newcombe" = prop_diff_nc(rsp, grp, conf_level, correct = FALSE),
105	2x	"newcombecc" = prop_diff_nc(rsp, grp, conf_level, correct = TRUE),
106	2x	"strat_newcombe" = prop_diff_strat_nc(rsp,
107	2x	grp,
108	2x	strata,
109	2x	weights_method,
110	2x	conf_level,
111	2x	correct = FALSE
112		),
113	2x	"strat_newcombecc" = prop_diff_strat_nc(rsp,
114	2x	grp,
115	2x	strata,
116	2x	weights_method,
117	2x	conf_level,
118	2x	correct = TRUE
119		),
120	2x	"cmh" = prop_diff_cmh(rsp, grp, strata, conf_level)[c("diff", "diff_ci")]
121		)
122
123	2x	y$diff <- y$diff * 100
124	2x	y$diff_ci <- y$diff_ci * 100
125		}
126
127	2x	attr(y$diff, "label") <- "Difference in Response rate (%)"
128	2x	attr(y$diff_ci, "label") <- d_proportion_diff(
129	2x	conf_level, method,
130	2x	long = FALSE
131		)
132
133	2x	y
134		}
135
136		#' @describeIn prop_diff Formatted Analysis function which can be further customized by calling
137		#' [rtables::make_afun()] on it. It is used as `afun` in [rtables::analyze()].
138		#'
139		#' @examples
140		#' a_proportion_diff(
141		#' df = subset(dta, grp == "A"),
142		#' .var = "rsp",
143		#' .ref_group = subset(dta, grp == "B"),
144		#' .in_ref_col = FALSE,
145		#' conf_level = 0.90,
146		#' method = "ha"
147		#' )
148		#'
149		#' @export
150		a_proportion_diff <- make_afun(
151		s_proportion_diff,
152		.formats = c(diff = "xx.x", diff_ci = "(xx.x, xx.x)"),
153		.indent_mods = c(diff = 0L, diff_ci = 1L)
154		)
155
156		#' @describeIn prop_diff Adds a descriptive analyze layer to `rtables`
157		#' pipelines. The analysis is applied to a `dataframe` and return the
158		#' estimations, in `rcells`. The ellipsis (`...`) conveys arguments to
159		#' `s_proportion_diff()`, for instance `na.rm = FALSE` if missing data
160		#' should be accounted for.
161		#' @inheritParams rtables::analyze
162		#' @param ... arguments passed to `s_proportion_diff()`.
163		#'
164		#' @examples
165		#' l <- basic_table() %>%
166		#' split_cols_by(var = "grp", ref_group = "B") %>%
167		#' estimate_proportion_diff(
168		#' vars = "rsp",
169		#' conf_level = 0.90,
170		#' method = "ha"
171		#' )
172		#'
173		#' build_table(l, df = dta)
174		#'
175		#' @export
176		estimate_proportion_diff <- function(lyt,
177		vars,
178		...,
179		var_labels = vars,
180		show_labels = "hidden",
181		table_names = vars,
182		.stats = NULL,
183		.formats = NULL,
184		.labels = NULL,
185		.indent_mods = NULL) {
186	3x	afun <- make_afun(
187	3x	a_proportion_diff,
188	3x	.stats = .stats,
189	3x	.formats = .formats,
190	3x	.labels = .labels,
191	3x	.indent_mods = .indent_mods
192		)
193
194	3x	analyze(
195	3x	lyt,
196	3x	vars,
197	3x	afun = afun,
198	3x	var_labels = var_labels,
199	3x	extra_args = list(...),
200	3x	show_labels = show_labels,
201	3x	table_names = table_names
202		)
203		}
204
205		#' Check: Proportion Difference Arguments
206		#'
207		#' Verifies that and/or convert arguments into valid values to be used in the
208		#' estimation of difference in responder proportions.
209		#'
210		#' @inheritParams prop_diff
211		#' @inheritParams prop_diff_wald
212		#'
213		#' @keywords internal
214		check_diff_prop_ci <- function(rsp,
215		grp,
216		strata = NULL,
217		conf_level,
218		correct = NULL) {
219	17x	checkmate::assert_logical(rsp, any.missing = FALSE)
220	17x	checkmate::assert_factor(grp, len = length(rsp), any.missing = FALSE, n.levels = 2)
221	17x	checkmate::assert_number(conf_level, lower = 0, upper = 1)
222	17x	checkmate::assert_flag(correct, null.ok = TRUE)
223
224	17x	if (!is.null(strata)) {
225	11x	checkmate::assert_factor(strata, len = length(rsp))
226		}
227
228	17x	invisible()
229		}
230
231		#' Description of Method Used for Proportion Comparison
232		#'
233		#' @description `r lifecycle::badge("stable")`
234		#'
235		#' This is an auxiliary function that describes the analysis in
236		#' `s_proportion_diff`.
237		#'
238		#' @inheritParams s_proportion_diff
239		#' @param long (`logical`)\cr Whether a long or a short (default) description is required.
240		#' @return String describing the analysis.
241		#' @seealso [prop_diff]
242		#'
243		#' @export
244		d_proportion_diff <- function(conf_level,
245		method,
246		long = FALSE) {
247	8x	label <- paste0(conf_level * 100, "% CI")
248	8x	if (long) {
249	!	label <- paste(
250	!	label,
251	!	ifelse(
252	!	method == "cmh",
253	!	"for adjusted difference",
254	!	"for difference"
255		)
256		)
257		}
258
259	8x	method_part <- switch(method,
260	8x	"cmh" = "CMH, without correction",
261	8x	"waldcc" = "Wald, with correction",
262	8x	"wald" = "Wald, without correction",
263	8x	"ha" = "Anderson-Hauck",
264	8x	"newcombe" = "Newcombe, without correction",
265	8x	"newcombecc" = "Newcombe, with correction",
266	8x	"strat_newcombe" = "Stratified Newcombe, without correction",
267	8x	"strat_newcombecc" = "Stratified Newcombe, with correction",
268	8x	stop(paste(method, "does not have a description"))
269		)
270	8x	paste0(label, " (", method_part, ")")
271		}
272
273		#' Helper Functions to Calculate Proportion Difference
274		#'
275		#' @description `r lifecycle::badge("stable")`
276		#'
277		#' @inheritParams argument_convention
278		#' @inheritParams prop_diff
279		#' @param grp (`factor`)\cr vector assigning observations to one out of two groups
280		#' (e.g. reference and treatment group).
281		#'
282		#' @seealso [prop_diff()] for implementation of these helper functions.
283		#'
284		#' @name h_prop_diff
285		NULL
286
287		#' @describeIn h_prop_diff The Wald interval follows the usual textbook
288		#' definition for a single proportion confidence interval using the normal
289		#' approximation. It is possible to include a continuity correction for Wald's
290		#' interval.
291		#'
292		#' @param correct `logical`\cr include the continuity correction. For further
293		#' information, see [stats::prop.test()].
294		#'
295		#' @examples
296		#' # Wald confidence interval
297		#' set.seed(2)
298		#' rsp <- sample(c(TRUE, FALSE), replace = TRUE, size = 20)
299		#' grp <- factor(c(rep("A", 10), rep("B", 10)))
300		#' prop_diff_wald(rsp = rsp, grp = grp, conf_level = 0.95, correct = FALSE)
301		#'
302		#' @export
303		prop_diff_wald <- function(rsp,
304		grp,
305		conf_level = 0.95,
306		correct = FALSE) {
307	2x	if (isTRUE(correct)) {
308	1x	mthd <- "waldcc"
309		} else {
310	1x	mthd <- "wald"
311		}
312	2x	grp <- as_factor_keep_attributes(grp)
313	2x	check_diff_prop_ci(
314	2x	rsp = rsp, grp = grp, conf_level = conf_level, correct = correct
315		)
316
317		# check if binary response is coded as logical
318	2x	checkmate::assert_logical(rsp, any.missing = FALSE)
319	2x	checkmate::assert_factor(grp, len = length(rsp), any.missing = FALSE, n.levels = 2)
320
321	2x	tbl <- table(grp, factor(rsp, levels = c(TRUE, FALSE)))
322		# x1 and n1 are non-reference groups.
323	2x	diff_ci <- desctools_binom(
324	2x	x1 = tbl[2], n1 = sum(tbl[2], tbl[4]),
325	2x	x2 = tbl[1], n2 = sum(tbl[1], tbl[3]),
326	2x	conf.level = conf_level,
327	2x	method = mthd
328		)
329
330	2x	list(
331	2x	"diff" = unname(diff_ci[, "est"]),
332	2x	"diff_ci" = unname(diff_ci[, c("lwr.ci", "upr.ci")])
333		)
334		}
335
336		#' @describeIn h_prop_diff Anderson-Hauck confidence interval.
337		#'
338		#' @examples
339		#' # Anderson-Hauck confidence interval
340		#' ## "Mid" case: 3/4 respond in group A, 1/2 respond in group B.
341		#' rsp <- c(TRUE, FALSE, FALSE, TRUE, TRUE, TRUE)
342		#' grp <- factor(c("A", "B", "A", "B", "A", "A"), levels = c("B", "A"))
343		#' prop_diff_ha(rsp = rsp, grp = grp, conf_level = 0.90)
344		#'
345		#' ## Edge case: Same proportion of response in A and B.
346		#' rsp <- c(TRUE, FALSE, TRUE, FALSE)
347		#' grp <- factor(c("A", "A", "B", "B"), levels = c("A", "B"))
348		#' prop_diff_ha(rsp = rsp, grp = grp, conf_level = 0.6)
349		#'
350		#' @export
351		prop_diff_ha <- function(rsp,
352		grp,
353		conf_level) {
354	3x	grp <- as_factor_keep_attributes(grp)
355	3x	check_diff_prop_ci(rsp = rsp, grp = grp, conf_level = conf_level)
356
357	3x	tbl <- table(grp, factor(rsp, levels = c(TRUE, FALSE)))
358		# x1 and n1 are non-reference groups.
359	3x	ci <- desctools_binom(
360	3x	x1 = tbl[2], n1 = sum(tbl[2], tbl[4]),
361	3x	x2 = tbl[1], n2 = sum(tbl[1], tbl[3]),
362	3x	conf.level = conf_level,
363	3x	method = "ha"
364		)
365	3x	list(
366	3x	"diff" = unname(ci[, "est"]),
367	3x	"diff_ci" = unname(ci[, c("lwr.ci", "upr.ci")])
368		)
369		}
370
371
372
373
374		#' @describeIn h_prop_diff Newcombe confidence interval. It is based on
375		#' the Wilson score confidence interval for a single binomial proportion.
376		#'
377		#' @examples
378		#' # Newcombe confidence interval
379		#'
380		#' set.seed(1)
381		#' rsp <- c(
382		#' sample(c(TRUE, FALSE), size = 40, prob = c(3 / 4, 1 / 4), replace = TRUE),
383		#' sample(c(TRUE, FALSE), size = 40, prob = c(1 / 2, 1 / 2), replace = TRUE)
384		#' )
385		#' grp <- factor(rep(c("A", "B"), each = 40), levels = c("B", "A"))
386		#' table(rsp, grp)
387		#' prop_diff_nc(rsp = rsp, grp = grp, conf_level = 0.9)
388		#'
389		#' @export
390		prop_diff_nc <- function(rsp,
391		grp,
392		conf_level,
393		correct = FALSE) {
394	1x	if (isTRUE(correct)) {
395	!	mthd <- "scorecc"
396		} else {
397	1x	mthd <- "score"
398		}
399	1x	grp <- as_factor_keep_attributes(grp)
400	1x	check_diff_prop_ci(rsp = rsp, grp = grp, conf_level = conf_level)
401
402	1x	p_grp <- tapply(rsp, grp, mean)
403	1x	diff_p <- unname(diff(p_grp))
404	1x	tbl <- table(grp, factor(rsp, levels = c(TRUE, FALSE)))
405	1x	ci <- desctools_binom(
406		# x1 and n1 are non-reference groups.
407	1x	x1 = tbl[2], n1 = sum(tbl[2], tbl[4]),
408	1x	x2 = tbl[1], n2 = sum(tbl[1], tbl[3]),
409	1x	conf.level = conf_level,
410	1x	method = mthd
411		)
412	1x	list(
413	1x	"diff" = unname(ci[, "est"]),
414	1x	"diff_ci" = unname(ci[, c("lwr.ci", "upr.ci")])
415		)
416		}
417
418
419		#' @describeIn h_prop_diff Calculates the weighted difference.
420		#' This is defined as the difference in response rates between the
421		#' experimental treatment group and the control treatment group, adjusted
422		#' for stratification factors by applying Cochran-Mantel-Haenszel (CMH)
423		#' weights. For the CMH chi-squared test, use [stats::mantelhaen.test()].
424		#'
425		#' @param strata (`factor`)\cr variable with one level per stratum and same length as `rsp`.
426		#'
427		#' @examples
428		#' # Cochran-Mantel-Haenszel confidence interval
429		#'
430		#' set.seed(2)
431		#' rsp <- sample(c(TRUE, FALSE), 100, TRUE)
432		#' grp <- sample(c("Placebo", "Treatment"), 100, TRUE)
433		#' grp <- factor(grp, levels = c("Placebo", "Treatment"))
434		#' strata_data <- data.frame(
435		#' "f1" = sample(c("a", "b"), 100, TRUE),
436		#' "f2" = sample(c("x", "y", "z"), 100, TRUE),
437		#' stringsAsFactors = TRUE
438		#' )
439		#'
440		#' prop_diff_cmh(
441		#' rsp = rsp, grp = grp, strata = interaction(strata_data),
442		#' conf_level = 0.90
443		#' )
444		#'
445		#' @export
446		prop_diff_cmh <- function(rsp,
447		grp,
448		strata,
449		conf_level = 0.95) {
450	7x	grp <- as_factor_keep_attributes(grp)
451	7x	strata <- as_factor_keep_attributes(strata)
452	7x	check_diff_prop_ci(
453	7x	rsp = rsp, grp = grp, conf_level = conf_level, strata = strata
454		)
455
456	7x	if (any(tapply(rsp, strata, length) < 5)) {
457	!	warning("Less than 5 observations in some strata.")
458		}
459
460		# first dimension: FALSE, TRUE
461		# 2nd dimension: CONTROL, TX
462		# 3rd dimension: levels of strat
463		# rsp as factor rsp to handle edge case of no FALSE (or TRUE) rsp records
464	7x	t_tbl <- table(
465	7x	factor(rsp, levels = c("FALSE", "TRUE")),
466	7x	grp,
467	7x	strata
468		)
469	7x	n1 <- colSums(t_tbl[1:2, 1, ])
470	7x	n2 <- colSums(t_tbl[1:2, 2, ])
471	7x	p1 <- t_tbl[2, 1, ] / n1
472	7x	p2 <- t_tbl[2, 2, ] / n2
473		# CMH weights
474	7x	use_stratum <- (n1 > 0) & (n2 > 0)
475	7x	n1 <- n1[use_stratum]
476	7x	n2 <- n2[use_stratum]
477	7x	p1 <- p1[use_stratum]
478	7x	p2 <- p2[use_stratum]
479	7x	wt <- (n1 * n2 / (n1 + n2))
480	7x	wt_normalized <- wt / sum(wt)
481	7x	est1 <- sum(wt_normalized * p1)
482	7x	est2 <- sum(wt_normalized * p2)
483	7x	estimate <- c(est1, est2)
484	7x	names(estimate) <- levels(grp)
485	7x	se1 <- sqrt(sum(wt_normalized^2 * p1 * (1 - p1) / n1))
486	7x	se2 <- sqrt(sum(wt_normalized^2 * p2 * (1 - p2) / n2))
487	7x	z <- stats::qnorm((1 + conf_level) / 2)
488	7x	err1 <- z * se1
489	7x	err2 <- z * se2
490	7x	ci1 <- c((est1 - err1), (est1 + err1))
491	7x	ci2 <- c((est2 - err2), (est2 + err2))
492	7x	estimate_ci <- list(ci1, ci2)
493	7x	names(estimate_ci) <- levels(grp)
494	7x	diff_est <- est2 - est1
495	7x	se_diff <- sqrt(sum(((p1 * (1 - p1) / n1) + (p2 * (1 - p2) / n2)) * wt_normalized^2))
496	7x	diff_ci <- c(diff_est - z * se_diff, diff_est + z * se_diff)
497
498	7x	list(
499	7x	prop = estimate,
500	7x	prop_ci = estimate_ci,
501	7x	diff = diff_est,
502	7x	diff_ci = diff_ci,
503	7x	weights = wt_normalized,
504	7x	n1 = n1,
505	7x	n2 = n2
506		)
507		}
508
509		#' @describeIn h_prop_diff Calculates the stratified Newcombe confidence interval
510		#' and difference in response rates between the experimental treatment group
511		#' and the control treatment group, adjusted for stratification factors. This
512		#' implementation follows closely the one proposed by
513		#' \insertCite{Yan2010-jt;textual}{tern}. Weights can be estimated from the
514		#' heuristic proposed in [prop_strat_wilson()] or from CMH-derived weights
515		#' (see [prop_diff_cmh()]).
516		#'
517		#' @param strata (`factor`)\cr variable with one level per stratum and same length as `rsp`.
518		#' @param weights_method (`string`)\cr weights method. Can be either `"cmh"` or `"heuristic"`
519		#' and directs the way weights are estimated.
520		#'
521		#' @examples
522		#' # Stratified Newcombe confidence interval
523		#'
524		#' set.seed(2)
525		#' data_set <- data.frame(
526		#' "rsp" = sample(c(TRUE, FALSE), 100, TRUE),
527		#' "f1" = sample(c("a", "b"), 100, TRUE),
528		#' "f2" = sample(c("x", "y", "z"), 100, TRUE),
529		#' "grp" = sample(c("Placebo", "Treatment"), 100, TRUE),
530		#' stringsAsFactors = TRUE
531		#' )
532		#'
533		#' prop_diff_strat_nc(
534		#' rsp = data_set$rsp, grp = data_set$grp, strata = interaction(data_set[2:3]),
535		#' weights_method = "cmh",
536		#' conf_level = 0.90
537		#' )
538		#'
539		#' prop_diff_strat_nc(
540		#' rsp = data_set$rsp, grp = data_set$grp, strata = interaction(data_set[2:3]),
541		#' weights_method = "wilson_h",
542		#' conf_level = 0.90
543		#' )
544		#'
545		#' @references
546		#' - \insertRef{Yan2010-jt}{tern}
547		#'
548		#' @importFrom Rdpack reprompt
549		#'
550		#' @export
551		prop_diff_strat_nc <- function(rsp,
552		grp,
553		strata,
554		weights_method = c("cmh", "wilson_h"),
555		conf_level = 0.95,
556		correct = FALSE) {
557	4x	weights_method <- match.arg(weights_method)
558	4x	grp <- as_factor_keep_attributes(grp)
559	4x	strata <- as_factor_keep_attributes(strata)
560	4x	check_diff_prop_ci(
561	4x	rsp = rsp, grp = grp, conf_level = conf_level, strata = strata
562		)
563	4x	checkmate::assert_number(conf_level, lower = 0, upper = 1)
564	4x	checkmate::assert_flag(correct)
565	4x	if (any(tapply(rsp, strata, length) < 5)) {
566	!	warning("Less than 5 observations in some strata.")
567		}
568
569	4x	rsp_by_grp <- split(rsp, f = grp)
570	4x	strata_by_grp <- split(strata, f = grp)
571
572		# Finding the weights
573	4x	weights <- if (identical(weights_method, "cmh")) {
574	3x	prop_diff_cmh(rsp = rsp, grp = grp, strata = strata)$weights
575	4x	} else if (identical(weights_method, "wilson_h")) {
576	1x	prop_strat_wilson(rsp, strata, conf_level = conf_level, correct = correct)$weights
577		}
578	4x	weights[levels(strata)[!levels(strata) %in% names(weights)]] <- 0
579
580		# Calculating lower (`l`) and upper (`u`) confidence bounds per group.
581	4x	strat_wilson_by_grp <- Map(
582	4x	prop_strat_wilson,
583	4x	rsp = rsp_by_grp,
584	4x	strata = strata_by_grp,
585	4x	weights = list(weights, weights),
586	4x	conf_level = conf_level,
587	4x	correct = correct
588		)
589
590	4x	ci_ref <- strat_wilson_by_grp[[1]]
591	4x	ci_trt <- strat_wilson_by_grp[[2]]
592	4x	l_ref <- as.numeric(ci_ref$conf_int[1])
593	4x	u_ref <- as.numeric(ci_ref$conf_int[2])
594	4x	l_trt <- as.numeric(ci_trt$conf_int[1])
595	4x	u_trt <- as.numeric(ci_trt$conf_int[2])
596
597		# Estimating the diff and n_ref, n_trt (it allows different weights to be used)
598	4x	t_tbl <- table(
599	4x	factor(rsp, levels = c("FALSE", "TRUE")),
600	4x	grp,
601	4x	strata
602		)
603	4x	n_ref <- colSums(t_tbl[1:2, 1, ])
604	4x	n_trt <- colSums(t_tbl[1:2, 2, ])
605	4x	use_stratum <- (n_ref > 0) & (n_trt > 0)
606	4x	n_ref <- n_ref[use_stratum]
607	4x	n_trt <- n_trt[use_stratum]
608	4x	p_ref <- t_tbl[2, 1, use_stratum] / n_ref
609	4x	p_trt <- t_tbl[2, 2, use_stratum] / n_trt
610	4x	est1 <- sum(weights * p_ref)
611	4x	est2 <- sum(weights * p_trt)
612	4x	diff_est <- est2 - est1
613
614	4x	lambda1 <- sum(weights^2 / n_ref)
615	4x	lambda2 <- sum(weights^2 / n_trt)
616	4x	z <- stats::qnorm((1 + conf_level) / 2)
617
618	4x	lower <- diff_est - z * sqrt(lambda2 * l_trt * (1 - l_trt) + lambda1 * u_ref * (1 - u_ref))
619	4x	upper <- diff_est + z * sqrt(lambda1 * l_ref * (1 - l_ref) + lambda2 * u_trt * (1 - u_trt))
620
621	4x	list(
622	4x	"diff" = diff_est,
623	4x	"diff_ci" = c("lower" = lower, "upper" = upper)
624		)
625		}

1		#' Pairwise Formula Special Term
2		#'
3		#' @description `r lifecycle::badge("stable")`
4		#'
5		#' The special term `pairwise` indicate that the model should be fitted individually for
6		#' every tested level in comparison to the reference level.
7		#'
8		#' @param x the variable for which pairwise result is expected
9		#'
10		#' @details Let's `ARM` being a factor with level A, B, C; let's be B the reference level,
11		#' a model calling the formula including `pairwise(ARM)` will result in two models:
12		#' * A model including only levels A and B, and effect of A estimated in reference to B.
13		#' * A model including only levels C and B, the effect of C estimated in reference to B.
14		#'
15		#' @export
16		pairwise <- function(x) {
17	1x	structure(x, varname = deparse(substitute(x)))
18		}
19
20		#' Univariate Formula Special Term
21		#'
22		#' @description `r lifecycle::badge("stable")`
23		#'
24		#' The special term `univariate` indicate that the model should be fitted individually for
25		#' every variable included in univariate.
26		#'
27		#' @param x A vector of variable name separated by comas.
28		#'
29		#' @details
30		#' If provided alongside with pairwise specification, the model
31		#' `y ~ ARM + univariate(SEX, AGE, RACE)` lead to the study and comparison of the models
32		#' + `y ~ ARM`
33		#' + `y ~ ARM + SEX`
34		#' + `y ~ ARM + AGE`
35		#' + `y ~ ARM + RACE`
36		#'
37		#' @export
38		univariate <- function(x) {
39	1x	structure(x, varname = deparse(substitute(x)))
40		}
41
42		# Get the right-hand-term of a formula
43		rht <- function(x) {
44	4x	checkmate::assert_formula(x)
45	4x	y <- as.character(rev(x)[[1]])
46	4x	return(y)
47		}
48
49		#' Hazard Ratio Estimation in Interactions
50		#'
51		#' This function estimates the hazard ratios between arms when an interaction variable is given with
52		#' specific values.
53		#'
54		#' @param variable,given Names of two variable in interaction. We seek the estimation of the levels of `variable`
55		#' given the levels of `given`.
56		#' @param lvl_var,lvl_given corresponding levels has given by `levels`.
57		#' @param mmat A name numeric filled with 0 used as template to obtain the design matrix.
58		#' @param coef Numeric of estimated coefficients.
59		#' @param vcov Variance-covariance matrix of underlying model.
60		#' @param conf_level Single numeric for the confidence level of estimate intervals.
61		#'
62		#' @details Given the cox regression investigating the effect of Arm (A, B, C; reference A)
63		#' and Sex (F, M; reference Female). The model is abbreviated: y ~ Arm + Sex + Arm x Sex.
64		#' The cox regression estimates the coefficients along with a variance-covariance matrix for:
65		#'
66		#' - b1 (arm b), b2 (arm c)
67		#' - b3 (sex m)
68		#' - b4 (arm b: sex m), b5 (arm c: sex m)
69		#'
70		#' Given that I want an estimation of the Hazard Ratio for arm C/sex M, the estimation
71		#' will be given in reference to arm A/Sex M by exp(b2 + b3 + b5)/ exp(b3) = exp(b2 + b5),
72		#' therefore the interaction coefficient is given by b2 + b5 while the standard error is obtained
73		#' as $1.96 * sqrt(Var b2 + Var b5 + 2 * covariance (b2,b5))$ for a confidence level of 0.95.
74		#'
75		#' @return A list of matrix (one per level of variable) with rows corresponding to the combinations of
76		#' `variable` and `given`, with columns:
77		#' \describe{
78		#' \item{coef_hat}{Estimation of the coefficient.}
79		#' \item{coef_se}{Standard error of the estimation.}
80		#' \item{hr}{Hazard ratio.}
81		#' \item{lcl, ucl}{Lower/upper confidence limit of the hazard ratio.}
82		#' }
83		#' @seealso [s_cox_multivariate()].
84		#'
85		#' @examples
86		#' library(dplyr)
87		#' library(survival)
88		#'
89		#' ADSL <- tern_ex_adsl %>%
90		#' filter(SEX %in% c("F", "M"))
91		#'
92		#' adtte <- tern_ex_adtte %>% filter(PARAMCD == "PFS")
93		#' adtte$ARMCD <- droplevels(adtte$ARMCD)
94		#' adtte$SEX <- droplevels(adtte$SEX)
95		#'
96		#' mod <- coxph(
97		#' formula = Surv(time = AVAL, event = 1 - CNSR) ~ (SEX + ARMCD)^2,
98		#' data = adtte
99		#' )
100		#'
101		#' mmat <- stats::model.matrix(mod)[1, ]
102		#' mmat[!mmat == 0] <- 0
103		#'
104		#' # Internal function - estimate_coef
105		#' \dontrun{
106		#' estimate_coef(
107		#' variable = "ARMCD", given = "SEX", lvl_var = "ARM A", lvl_given = "M",
108		#' coef = stats::coef(mod), mmat = mmat, vcov = stats::vcov(mod), conf_level = .95
109		#' )
110		#' }
111		#'
112		#' @keywords internal
113		estimate_coef <- function(variable, given,
114		lvl_var, lvl_given,
115		coef,
116		mmat,
117		vcov,
118		conf_level = 0.95) {
119	8x	var_lvl <- paste0(variable, lvl_var[-1]) # [-1]: reference level
120	8x	giv_lvl <- paste0(given, lvl_given)
121
122	8x	design_mat <- expand.grid(variable = var_lvl, given = giv_lvl)
123	8x	design_mat <- design_mat[order(design_mat$variable, design_mat$given), ]
124	8x	design_mat <- within(
125	8x	data = design_mat,
126	8x	expr = {
127	8x	inter <- paste0(variable, ":", given) # nolint
128	8x	rev_inter <- paste0(given, ":", variable) # nolint
129		}
130		)
131
132	8x	split_by_variable <- design_mat$variable
133	8x	interaction_names <- paste(design_mat$variable, design_mat$given, sep = "/")
134
135	8x	design_mat <- apply(
136	8x	X = design_mat, MARGIN = 1, FUN = function(x) {
137	27x	mmat[names(mmat) %in% x[-which(names(x) == "given")]] <- 1
138	27x	return(mmat)
139		}
140		)
141	8x	colnames(design_mat) <- interaction_names
142
143	8x	betas <- as.matrix(coef)
144
145	8x	coef_hat <- t(design_mat) %*% betas
146	8x	dimnames(coef_hat)[2] <- "coef"
147
148	8x	coef_se <- apply(design_mat, 2, function(x) {
149	27x	vcov_el <- as.logical(x)
150	27x	y <- vcov[vcov_el, vcov_el]
151	27x	y <- sum(y)
152	27x	y <- sqrt(y)
153	27x	return(y)
154		})
155
156	8x	q_norm <- stats::qnorm((1 + conf_level) / 2)
157	8x	y <- cbind(coef_hat, `se(coef)` = coef_se)
158
159	8x	y <- apply(y, 1, function(x) {
160	27x	x["hr"] <- exp(x["coef"])
161	27x	x["lcl"] <- exp(x["coef"] - q_norm * x["se(coef)"])
162	27x	x["ucl"] <- exp(x["coef"] + q_norm * x["se(coef)"])
163
164	27x	return(x)
165		})
166
167	8x	y <- t(y)
168	8x	y <- by(y, split_by_variable, identity)
169	8x	y <- lapply(y, as.matrix)
170
171	8x	attr(y, "details") <- paste0(
172	8x	"Estimations of ", variable,
173	8x	" hazard ratio given the level of ", given, " compared to ",
174	8x	variable, " level ", lvl_var[1], "."
175		)
176	8x	return(y)
177		}
178
179		#' `tryCatch` around `car::Anova`
180		#'
181		#' Captures warnings when executing [car::Anova].
182		#'
183		#' @inheritParams car::Anova
184		#'
185		#' @return A list with item `aov` for the result of the model and
186		#' `error_text` for the captured warnings.
187		#'
188		#' @examples
189		#' # `car::Anova` on cox regression model including strata and expected
190		#' # a likelihood ratio test triggers a warning as only Wald method is
191		#' # accepted.
192		#'
193		#' library(survival)
194		#'
195		#' mod <- coxph(
196		#' formula = Surv(time = futime, event = fustat) ~ factor(rx) + strata(ecog.ps),
197		#' data = ovarian
198		#' )
199		#'
200		#' # Internal function - try_car_anova
201		#' \dontrun{
202		#' with_wald <- try_car_anova(mod = mod, test.statistic = "Wald")
203		#' with_lr <- try_car_anova(mod = mod, test.statistic = "LR")
204		#' }
205		#'
206		#' @keywords internal
207		try_car_anova <- function(mod,
208		test.statistic) { # nolint
209	2x	y <- tryCatch(
210	2x	withCallingHandlers(
211	2x	expr = {
212	2x	warn_text <- c()
213	2x	list(
214	2x	aov = car::Anova(
215	2x	mod,
216	2x	test.statistic = test.statistic,
217	2x	type = "III"
218		),
219	2x	warn_text = warn_text
220		)
221		},
222	2x	warning = function(w) {
223		# If a warning is detected it is handled as "w".
224	!	warn_text <<- trimws(paste0("Warning in `try_car_anova`: ", w))
225
226		# A warning is sometimes expected, then, we want to restart
227		# the execution while ignoring the warning.
228	!	invokeRestart("muffleWarning")
229		}
230		),
231	2x	finally = {
232		}
233		)
234
235	2x	return(y)
236		}
237
238		#' Fit the Cox Regression Model and Anova
239		#'
240		#' The functions allows to derive from the [survival::coxph()] results
241		#' the effect p.values using [car::Anova()]. This last package introduces
242		#' more flexibility to get the effect p.values.
243		#'
244		#' @inheritParams t_coxreg
245		#' @noRd
246		#'
247		#' @return A list with items `mod` (results of [survival::coxph()]),
248		#' `msum` (result of `summary`) and `aov` (result of [car::Anova]).
249		fit_n_aov <- function(formula,
250		data = data,
251		conf_level = conf_level,
252		pval_method = c("wald", "likelihood"),
253		...) {
254	1x	pval_method <- match.arg(pval_method)
255
256	1x	environment(formula) <- environment()
257	1x	suppressWarnings({
258		# We expect some warnings due to coxph which fails strict programming.
259	1x	mod <- survival::coxph(formula, data = data, ...)
260	1x	msum <- summary(mod, conf.int = conf_level)
261		})
262
263	1x	aov <- try_car_anova(
264	1x	mod,
265	1x	test.statistic = switch(pval_method,
266	1x	"wald" = "Wald",
267	1x	"likelihood" = "LR"
268		)
269		)
270
271	1x	warn_attr <- aov$warn_text
272	!	if (!is.null(aov$warn_text)) message(warn_attr)
273
274	1x	aov <- aov$aov
275	1x	y <- list(mod = mod, msum = msum, aov = aov)
276	1x	attr(y, "message") <- warn_attr
277
278	1x	return(y)
279		}
280
281		# argument_checks
282		check_formula <- function(formula) {
283	1x	if (!(inherits(formula, "formula"))) {
284	1x	stop("Check `formula`. A formula should resemble `Surv(time = AVAL, event = 1 - CNSR) ~ study_arm(ARMCD)`.")
285		}
286
287	!	invisible()
288		}
289
290		check_covariate_formulas <- function(covariates) {
291	1x	if (!all(vapply(X = covariates, FUN = inherits, what = "formula", FUN.VALUE = TRUE)) \|\| is.null(covariates)) {
292	1x	stop("Check `covariates`, it should be a list of right-hand-term formulas, e.g. list(Age = ~AGE).")
293		}
294
295	!	invisible()
296		}
297
298		name_covariate_names <- function(covariates) {
299	1x	miss_names <- names(covariates) == ""
300	1x	no_names <- is.null(names(covariates))
301	!	if (any(miss_names)) names(covariates)[miss_names] <- vapply(covariates[miss_names], FUN = rht, FUN.VALUE = "name")
302	!	if (no_names) names(covariates) <- vapply(covariates, FUN = rht, FUN.VALUE = "name")
303	1x	return(covariates)
304		}
305
306		check_increments <- function(increments, covariates) {
307	1x	if (!is.null(increments)) {
308	1x	covariates <- vapply(covariates, FUN = rht, FUN.VALUE = "name")
309	1x	lapply(
310	1x	X = names(increments), FUN = function(x) {
311	3x	if (!x %in% covariates) {
312	1x	warning(
313	1x	paste(
314	1x	"Check `increments`, the `increment` for ", x,
315	1x	"doesn't match any names in investigated covariate(s)."
316		)
317		)
318		}
319		}
320		)
321		}
322
323	1x	invisible()
324		}
325
326		#' Multivariate Cox Model - Summarized Results
327		#'
328		#' Analyses based on multivariate Cox model are usually not performed for the Controlled Substance Reporting or
329		#' regulatory documents but serve exploratory purposes only (e.g., for publication). In practice, the model usually
330		#' includes only the main effects (without interaction terms). It produces the hazard ratio estimates for each of the
331		#' covariates included in the model.
332		#' The analysis follows the same principles (e.g., stratified vs. unstratified analysis and tie handling) as the
333		#' usual Cox model analysis. Since there is usually no pre-specified hypothesis testing for such analysis,
334		#' the p.values need to be interpreted with caution. (Statistical Analysis of Clinical Trials Data with R,
335		#' `NEST's bookdown`)
336		#'
337		#' @param formula (`formula`)\cr A formula corresponding to the investigated [survival::Surv()] survival model
338		#' including covariates.
339		#' @param data (`data.frame`)\cr A data frame which includes the variable in formula and covariates.
340		#' @param conf_level (`proportion`)\cr The confidence level for the hazard ratio interval estimations. Default is 0.95.
341		#' @param pval_method (`character`)\cr The method used for the estimation of p-values, should be one of
342		#' "wald" (default) or "likelihood".
343		#' @param ... Optional parameters passed to [survival::coxph()]. Can include `ties`, a character string specifying the
344		#' method for tie handling, one of `exact` (default), `efron`, `breslow`.
345		#'
346		#' @details The output is limited to single effect terms. Work in ongoing for estimation of interaction terms
347		#' but is out of scope as defined by the Global Data Standards Repository
348		#' (`GDS_Standard_TLG_Specs_Tables_2.doc`).
349		#' @seealso [estimate_coef()].
350		#'
351		#' @examples
352		#' library(dplyr)
353		#'
354		#' adtte <- tern_ex_adtte
355		#' adtte_f <- subset(adtte, PARAMCD == "OS") # _f: filtered
356		#' adtte_f <- filter(
357		#' adtte_f,
358		#' PARAMCD == "OS" &
359		#' SEX %in% c("F", "M") &
360		#' RACE %in% c("ASIAN", "BLACK OR AFRICAN AMERICAN", "WHITE")
361		#' )
362		#' adtte_f$SEX <- droplevels(adtte_f$SEX)
363		#' adtte_f$RACE <- droplevels(adtte_f$RACE)
364		#'
365		#' # Internal function - s_cox_multivariate
366		#' \dontrun{
367		#' s_cox_multivariate(
368		#' formula = Surv(time = AVAL, event = 1 - CNSR) ~ (ARMCD + RACE + AGE)^2, data = adtte_f
369		#' )
370		#' }
371		#'
372		#' @keywords internal
373		s_cox_multivariate <- function(formula, data,
374		conf_level = 0.95,
375		pval_method = c("wald", "likelihood"),
376		...) {
377	1x	tf <- stats::terms(formula, specials = c("strata"))
378	1x	covariates <- rownames(attr(tf, "factors"))[-c(1, unlist(attr(tf, "specials")))]
379	1x	lapply(
380	1x	X = covariates,
381	1x	FUN = function(x) {
382	3x	if (is.character(data[[x]])) {
383	1x	data[[x]] <<- as.factor(data[[x]])
384		}
385	3x	invisible()
386		}
387		)
388	1x	pval_method <- match.arg(pval_method)
389
390		# Results directly exported from environment(fit_n_aov) to environment(s_function_draft)
391	1x	y <- fit_n_aov(
392	1x	formula = formula,
393	1x	data = data,
394	1x	conf_level = conf_level,
395	1x	pval_method = pval_method,
396		...
397		)
398	1x	mod <- y$mod
399	1x	aov <- y$aov
400	1x	msum <- y$msum
401	1x	list2env(as.list(y), environment())
402
403	1x	all_term_labs <- attr(mod$terms, "term.labels")
404	1x	term_labs <- all_term_labs[which(attr(mod$terms, "order") == 1)]
405	1x	names(term_labs) <- term_labs
406
407	1x	coef_inter <- NULL
408	1x	if (any(attr(mod$terms, "order") > 1)) {
409	1x	for_inter <- all_term_labs[attr(mod$terms, "order") > 1]
410	1x	names(for_inter) <- for_inter
411	1x	mmat <- stats::model.matrix(mod)[1, ]
412	1x	mmat[!mmat == 0] <- 0
413	1x	mcoef <- stats::coef(mod)
414	1x	mvcov <- stats::vcov(mod)
415
416	1x	estimate_coef_local <- function(variable, given) {
417	6x	estimate_coef(
418	6x	variable, given,
419	6x	coef = mcoef, mmat = mmat, vcov = mvcov, conf_level = conf_level,
420	6x	lvl_var = levels(data[[variable]]), lvl_given = levels(data[[given]])
421		)
422		}
423
424	1x	coef_inter <- lapply(
425	1x	for_inter, function(x) {
426	3x	y <- attr(mod$terms, "factor")[, x]
427	3x	y <- names(y[y > 0])
428	3x	Map(estimate_coef_local, variable = y, given = rev(y))
429		}
430		)
431		}
432
433	1x	list(mod = mod, msum = msum, aov = aov, coef_inter = coef_inter)
434		}

1		#' Incidence Rate
2		#'
3		#' @description `r lifecycle::badge("stable")`
4		#'
5		#' Estimate the event rate adjusted for person-years at risk, otherwise known
6		#' as incidence rate. Primary analysis variable is the person-years at risk.
7		#'
8		#' @inheritParams argument_convention
9		#' @param control (`list`)\cr parameters for estimation details, specified by using
10		#' the helper function [control_incidence_rate()]. Possible parameter options are:
11		#' * `conf_level` (`proportion`)\cr confidence level for the estimated incidence rate.
12		#' * `conf_type` (`string`)\cr `normal` (default), `normal_log`, `exact`, or `byar`
13		#' for confidence interval type.
14		#' * `time_unit_input` (`string`)\cr `day`, `week`, `month`, or `year` (default)
15		#' indicating time unit for data input.
16		#' * `time_unit_output` (`numeric`)\cr time unit for desired output (in person-years).
17		#' @param person_years (`numeric`)\cr total person-years at risk.
18		#' @param alpha (`numeric`)\cr two-sided alpha-level for confidence interval.
19		#' @param n_events (`integer`)\cr number of events observed.
20		#'
21		#' @seealso [control_incidence_rate()] and helper functions [h_incidence_rate].
22		#'
23		#' @name incidence_rate
24		NULL
25
26		#' @describeIn incidence_rate Statistics function which estimates the incidence rate and the
27		#' associated confidence interval.
28		#'
29		#' @return The statistics are:
30		#' \describe{
31		#' \item{person_years}{total person-years at risk}
32		#' \item{n_events}{total number of events observed}
33		#' \item{rate}{estimated incidence rate}
34		#' \item{rate_ci}{confidence interval for the incidence rate}
35		#' }
36		#'
37		#' @examples
38		#' library(dplyr)
39		#'
40		#' df <- data.frame(
41		#' USUBJID = as.character(seq(6)),
42		#' CNSR = c(0, 1, 1, 0, 0, 0),
43		#' AVAL = c(10.1, 20.4, 15.3, 20.8, 18.7, 23.4),
44		#' ARM = factor(c("A", "A", "A", "B", "B", "B"))
45		#' ) %>%
46		#' mutate(is_event = CNSR == 0) %>%
47		#' mutate(n_events = as.integer(is_event))
48		#'
49		#' # Internal function - s_incidence_rate
50		#' \dontrun{
51		#' s_incidence_rate(
52		#' df,
53		#' .var = "AVAL",
54		#' n_events = "n_events",
55		#' control = control_incidence_rate(
56		#' time_unit_input = "month",
57		#' time_unit_output = 100
58		#' )
59		#' )
60		#' }
61		#'
62		#' @keywords internal
63		s_incidence_rate <- function(df,
64		.var,
65		n_events,
66		is_event,
67		control = control_incidence_rate()) {
68	1x	if (!missing(is_event)) {
69	!	warning("argument is_event will be deprecated. Please use n_events.")
70
71	!	if (missing(n_events)) {
72	!	assert_df_with_variables(df, list(tte = .var, is_event = is_event))
73	!	checkmate::assert_string(.var)
74	!	checkmate::assert_logical(df[[is_event]], any.missing = FALSE)
75	!	checkmate::assert_numeric(df[[.var]], any.missing = FALSE)
76	!	n_events <- is_event
77		}
78		} else {
79	1x	assert_df_with_variables(df, list(tte = .var, n_events = n_events))
80	1x	checkmate::assert_string(.var)
81	1x	checkmate::assert_numeric(df[[.var]], any.missing = FALSE)
82	1x	checkmate::assert_integer(df[[n_events]], any.missing = FALSE)
83		}
84
85	1x	time_unit_input <- control$time_unit_input
86	1x	time_unit_output <- control$time_unit_output
87	1x	conf_level <- control$conf_level
88	1x	person_years <- sum(df[[.var]], na.rm = TRUE) * (
89	1x	1 * (time_unit_input == "year") +
90	1x	1 / 12 * (time_unit_input == "month") +
91	1x	1 / 52.14 * (time_unit_input == "week") +
92	1x	1 / 365.24 * (time_unit_input == "day")
93		)
94	1x	n_events <- sum(df[[n_events]], na.rm = TRUE)
95
96	1x	result <- h_incidence_rate(
97	1x	person_years,
98	1x	n_events,
99	1x	control
100		)
101	1x	list(
102	1x	person_years = formatters::with_label(person_years, "Total patient-years at risk"),
103	1x	n_events = formatters::with_label(n_events, "Number of adverse events observed"),
104	1x	rate = formatters::with_label(result$rate, paste("AE rate per", time_unit_output, "patient-years")),
105	1x	rate_ci = formatters::with_label(result$rate_ci, f_conf_level(conf_level))
106		)
107		}
108
109
110		#' @describeIn incidence_rate Formatted Analysis function which can be further customized by calling
111		#' [rtables::make_afun()] on it. It is used as `afun` in [rtables::analyze()].
112		#'
113		#' @examples
114		#' # Internal function - a_incidence_rate
115		#' \dontrun{
116		#' a_incidence_rate(
117		#' df,
118		#' .var = "AVAL",
119		#' n_events = "n_events",
120		#' control = control_incidence_rate(time_unit_input = "month", time_unit_output = 100)
121		#' )
122		#' }
123		#'
124		#' @keywords internal
125		a_incidence_rate <- make_afun(
126		s_incidence_rate,
127		.formats = c(
128		"person_years" = "xx.x",
129		"n_events" = "xx",
130		"rate" = "xx.xx",
131		"rate_ci" = "(xx.xx, xx.xx)"
132		)
133		)
134
135		#' @describeIn incidence_rate Layout creating function which adds analyze rows using the statistics
136		#' function `s_incidence_rate` and desired format.
137		#'
138		#' @examples
139		#' basic_table() %>%
140		#' split_cols_by("ARM") %>%
141		#' add_colcounts() %>%
142		#' estimate_incidence_rate(
143		#' vars = "AVAL",
144		#' n_events = "n_events",
145		#' control = control_incidence_rate(
146		#' time_unit_input = "month",
147		#' time_unit_output = 100
148		#' )
149		#' ) %>%
150		#' build_table(df)
151		#'
152		#' @export
153		estimate_incidence_rate <- function(lyt,
154		vars,
155		...,
156		show_labels = "hidden",
157		table_names = vars,
158		.stats = NULL,
159		.formats = NULL,
160		.labels = NULL,
161		.indent_mods = NULL) {
162	1x	afun <- make_afun(
163	1x	a_incidence_rate,
164	1x	.stats = .stats,
165	1x	.formats = .formats,
166	1x	.labels = .labels,
167	1x	.indent_mods = .indent_mods
168		)
169
170	1x	analyze(
171	1x	lyt,
172	1x	vars,
173	1x	show_labels = show_labels,
174	1x	table_names = table_names,
175	1x	afun = afun,
176	1x	extra_args = list(...)
177		)
178		}
179
180		#' Helper Functions for Incidence Rate
181		#'
182		#' @description `r lifecycle::badge("stable")`
183		#'
184		#' @param control (`list`)\cr parameters for estimation details, specified by using
185		#' the helper function [control_incidence_rate()]. Possible parameter options are:
186		#' * `conf_level`: (`proportion`)\cr confidence level for the estimated incidence rate.
187		#' * `conf_type`: (`string`)\cr `normal` (default), `normal_log`, `exact`, or `byar`
188		#' for confidence interval type.
189		#' * `time_unit_input`: (`string`)\cr `day`, `week`, `month`, or `year` (default)
190		#' indicating time unit for data input.
191		#' * `time_unit_output`: (`numeric`)\cr time unit for desired output (in person-years).
192		#'
193		#' @param person_years (`numeric`)\cr total person-years at risk.
194		#' @param alpha (`numeric`)\cr two-sided alpha-level for confidence interval.
195		#' @param n_events (`integer`)\cr number of events observed.
196		#'
197		#' @seealso [incidence_rate]
198		#'
199		#' @name h_incidence_rate
200		NULL
201
202		#' @describeIn h_incidence_rate Helper function to estimate the incidence rate and
203		#' associated confidence interval based on the normal approximation for the
204		#' incidence rate. Unit is one person-year.
205		#'
206		#' @examples
207		#' h_incidence_rate_normal(200, 2)
208		#'
209		#' @export
210		h_incidence_rate_normal <- function(person_years,
211		n_events,
212		alpha = 0.05) {
213	1x	checkmate::assert_number(person_years)
214	1x	checkmate::assert_number(n_events)
215	1x	assert_proportion_value(alpha)
216
217	1x	est <- n_events / person_years
218	1x	se <- sqrt(est / person_years)
219	1x	ci <- est + c(-1, 1) * stats::qnorm(1 - alpha / 2) * se
220
221	1x	list(rate = est, rate_ci = ci)
222		}
223
224		#' @describeIn h_incidence_rate Helper function to estimate the incidence rate and
225		#' associated confidence interval based on the normal approximation for the
226		#' logarithm of the incidence rate. Unit is one person-year.
227		#'
228		#' @examples
229		#' h_incidence_rate_normal_log(200, 2)
230		#'
231		#' @export
232		h_incidence_rate_normal_log <- function(person_years,
233		n_events,
234		alpha = 0.05) {
235	5x	checkmate::assert_number(person_years)
236	5x	checkmate::assert_number(n_events)
237	5x	assert_proportion_value(alpha)
238
239	5x	rate_est <- n_events / person_years
240	5x	rate_se <- sqrt(rate_est / person_years)
241	5x	lrate_est <- log(rate_est)
242	5x	lrate_se <- rate_se / rate_est
243	5x	ci <- exp(lrate_est + c(-1, 1) * stats::qnorm(1 - alpha / 2) * lrate_se)
244
245	5x	list(rate = rate_est, rate_ci = ci)
246		}
247
248		#' @describeIn h_incidence_rate Helper function to estimate the incidence rate and
249		#' associated exact confidence interval. Unit is one person-year.
250		#'
251		#' @examples
252		#' h_incidence_rate_exact(200, 2)
253		#'
254		#' @export
255		h_incidence_rate_exact <- function(person_years,
256		n_events,
257		alpha = 0.05) {
258	1x	checkmate::assert_number(person_years)
259	1x	checkmate::assert_number(n_events)
260	1x	assert_proportion_value(alpha)
261
262	1x	est <- n_events / person_years
263	1x	lcl <- stats::qchisq(p = (alpha) / 2, df = 2 * n_events) / (2 * person_years)
264	1x	ucl <- stats::qchisq(p = 1 - (alpha) / 2, df = 2 * n_events + 2) / (2 * person_years)
265
266	1x	list(rate = est, rate_ci = c(lcl, ucl))
267		}
268
269		#' @describeIn h_incidence_rate Helper function to estimate the incidence rate and
270		#' associated Byar's confidence interval. Unit is one person-year.
271		#'
272		#' @examples
273		#' h_incidence_rate_byar(200, 2)
274		#'
275		#' @export
276		h_incidence_rate_byar <- function(person_years,
277		n_events,
278		alpha = 0.05) {
279	1x	checkmate::assert_number(person_years)
280	1x	checkmate::assert_number(n_events)
281	1x	assert_proportion_value(alpha)
282
283	1x	est <- n_events / person_years
284	1x	seg_1 <- n_events + 0.5
285	1x	seg_2 <- 1 - 1 / (9 * (n_events + 0.5))
286	1x	seg_3 <- stats::qnorm(1 - alpha / 2) * sqrt(1 / (n_events + 0.5)) / 3
287	1x	lcl <- seg_1 * ((seg_2 - seg_3)^3) / person_years
288	1x	ucl <- seg_1 * ((seg_2 + seg_3) ^ 3) / person_years # styler: off
289
290	1x	list(rate = est, rate_ci = c(lcl, ucl))
291		}
292
293		#' @describeIn h_incidence_rate Helper function to estimate the incidence rate and
294		#' associated confidence interval.
295		#'
296		#' @examples
297		#' # Internal function - h_incidence_rate
298		#' \dontrun{
299		#' h_incidence_rate(200, 2)
300		#'
301		#' h_incidence_rate(
302		#' 200,
303		#' 2,
304		#' control_incidence_rate(
305		#' conf_level = 0.9,
306		#' conf_type = "normal_log",
307		#' time_unit_output = 100
308		#' )
309		#' )
310		#' }
311		#'
312		#' @keywords internal
313		h_incidence_rate <- function(person_years,
314		n_events,
315		control = control_incidence_rate()) {
316	4x	alpha <- 1 - control$conf_level
317	4x	est <- switch(control$conf_type,
318	4x	normal = h_incidence_rate_normal(person_years, n_events, alpha),
319	4x	normal_log = h_incidence_rate_normal_log(person_years, n_events, alpha),
320	4x	exact = h_incidence_rate_exact(person_years, n_events, alpha),
321	4x	byar = h_incidence_rate_byar(person_years, n_events, alpha)
322		)
323
324	4x	time_unit_output <- control$time_unit_output
325	4x	list(
326	4x	rate = est$rate * time_unit_output,
327	4x	rate_ci = est$rate_ci * time_unit_output
328		)
329		}

1		#' Re-implemented \code{\link[base:range]{range.default}} default S3 method for numerical objects only.
2		#' It returns \code{c(NA, NA)} instead of \code{c(-Inf, Inf)} for zero-length data
3		#' without any warnings.
4		#'
5		#' @param x numeric S3 class, a sequence of numbers for which the range is computed.
6		#' @param na.rm (`logical`)\cr indicating if NA should be omitted.
7		#' @param finite (`logical`)\cr indicating if non-finite elements should be removed.
8		#'
9		#' @return 2-elements vector of class numeric.
10		#'
11		#' @examples
12		#' # Internal function - range_noinf
13		#' \dontrun{
14		#' range_noinf(1:5)
15		#' range_noinf(c(1:5, NA, NA), na.rm = TRUE)
16		#' range_noinf(numeric(), na.rm = TRUE)
17		#' range_noinf(c(1:5, NA, NA, Inf), na.rm = TRUE, finite = TRUE)
18		#' range_noinf(Inf)
19		#' range_noinf(Inf, na.rm = TRUE, finite = TRUE)
20		#' range_noinf(c(Inf, NA), na.rm = FALSE, finite = TRUE)
21		#' range_noinf(c(1, Inf, NA), na.rm = FALSE, finite = TRUE)
22		#' }
23		#'
24		#' @keywords internal
25		range_noinf <- function(x, na.rm = FALSE, finite = FALSE) { # nolint
26
27	652x	checkmate::assert_numeric(x)
28
29	652x	if (finite) {
30	24x	x <- x[is.finite(x)] # removes NAs too
31	628x	} else if (na.rm) {
32	468x	x <- x[!is.na(x)]
33		}
34
35	652x	if (length(x) == 0) {
36	44x	rval <- c(NA, NA)
37	44x	mode(rval) <- typeof(x)
38		} else {
39	608x	rval <- c(min(x, na.rm = FALSE), max(x, na.rm = FALSE))
40		}
41
42	652x	return(rval)
43		}
44
45		#' Utility function to create label for confidence interval
46		#'
47		#' @description `r lifecycle::badge("stable")`
48		#'
49		#' @inheritParams argument_convention
50		#' @return a `string`
51		#'
52		#' @export
53		f_conf_level <- function(conf_level) {
54	755x	assert_proportion_value(conf_level)
55	753x	paste0(conf_level * 100, "% CI")
56		}
57
58		#' Utility function to create label for p-value
59		#'
60		#' @description `r lifecycle::badge("stable")`
61		#'
62		#' @param test_mean (`number`)\cr mean value to test under the null hypothesis.
63		#' @return a `string`
64		#'
65		#' @export
66		f_pval <- function(test_mean) {
67	151x	checkmate::assert_numeric(test_mean, len = 1)
68	149x	paste0("p-value (H0: mean = ", test_mean, ")")
69		}
70
71		#' Utility function to return a named list of covariate names.
72		#'
73		#' @param covariates (`character`)\cr a vector that can contain single variable names (such as
74		#' `"X1"`), and/or interaction terms indicated by `"X1 * X2"`.
75		#' @return a named `list` of character vector.
76		#'
77		#' @keywords internal
78		get_covariates <- function(covariates) {
79	14x	checkmate::assert_character(covariates)
80	12x	cov_vars <- unique(trimws(unlist(strsplit(covariates, "\\*"))))
81	12x	stats::setNames(as.list(cov_vars), cov_vars)
82		}
83
84		#' Replicate Entries of a Vector if Required
85		#'
86		#' @description `r lifecycle::badge("stable")`
87		#'
88		#' Replicate entries of a vector if required. Note that this will fail if `x`
89		#' is not of length `n` or is not a scalar.
90		#'
91		#' @inheritParams argument_convention
92		#' @param n (`count`)\cr how many entries we need.
93		#'
94		#' @return Just input `x` if it has the required length already or is `NULL`,
95		#' otherwise if it is scalar the replicated version of it with `n` entries.
96		#'
97		#' @export
98		to_n <- function(x, n) {
99	1x	if (is.null(x)) {
100	!	NULL
101	1x	} else if (length(x) == 1) {
102	!	rep(x, n)
103	1x	} else if (length(x) == n) {
104	1x	x
105		} else {
106	!	stop("dimension mismatch")
107		}
108		}
109
110		#' Check Element Dimension
111		#'
112		#' @description
113		#'
114		#' Checks if the elements in `...` have the same dimension.
115		#'
116		#' @param ... data.frames or vectors
117		#' @param omit_null are \code{NULL} elements in \code{...} to be omitted from the check?
118		#'
119		#' @keywords internal
120		check_same_n <- function(..., omit_null = TRUE) {
121	2x	dots <- list(...)
122
123	2x	n_list <- Map(
124	2x	function(x, name) {
125	5x	if (is.null(x)) {
126	!	if (omit_null) {
127	2x	NA_integer_
128		} else {
129	!	stop("arg", name, "is not supposed to be NULL")
130		}
131	5x	} else if (is.data.frame(x)) {
132	!	nrow(x)
133	5x	} else if (is.atomic(x)) {
134	5x	length(x)
135		} else {
136	!	stop("data structure for ", name, "is currently not supported")
137		}
138		},
139	2x	dots, names(dots)
140		)
141
142	2x	n <- stats::na.omit(unlist(n_list))
143
144	2x	if (length(unique(n)) > 1) {
145	!	sel <- which(n != n[1])
146	!	stop("dimension mismatch:", paste(names(n)[sel], collapse = ", "), " do not have N=", n[1])
147		}
148
149	2x	TRUE
150		}
151
152		#' Make Names Without Dots
153		#'
154		#' @param nams (`character`)\cr vector of original names.
155		#'
156		#' @return Character vector of proper names, which does not use dots in contrast to
157		#' [base::make.names()].
158		#'
159		#' @examples
160		#' # Internal function - make_names
161		#' \dontrun{
162		#' make_names(c("foo Bar", "1 2 3 bla"))
163		#' }
164		#'
165		#' @keywords internal
166		make_names <- function(nams) {
167	6x	orig <- make.names(nams)
168	6x	gsub(".", "", x = orig, fixed = TRUE)
169		}
170
171		#' Conversion of Months to Days
172		#'
173		#' @description
174		#'
175		#' Conversion of Months to Days. This is an approximative calculation because it
176		#' considers each month as having an average of 30.4375 days.
177		#'
178		#' @param x (`numeric`)\cr time in months.
179		#'
180		#' @return A `numeric` vector with the time in days.
181		#'
182		#' @examples
183		#' x <- c(13.25, 8.15, 1, 2.834)
184		#' month2day(x)
185		#'
186		#' @export
187		month2day <- function(x) {
188	1x	checkmate::assert_numeric(x)
189	1x	x * 30.4375
190		}
191
192		#' Conversion of Days to Months
193		#'
194		#' @param x (`numeric`)\cr time in days.
195		#'
196		#' @return A `numeric` vector with the time in months.
197		#'
198		#' @examples
199		#' x <- c(403, 248, 30, 86)
200		#' day2month(x)
201		#'
202		#' @export
203		day2month <- function(x) {
204	15x	checkmate::assert_numeric(x)
205	15x	x / 30.4375
206		}
207
208		#' Return an empty numeric if all elements are `NA`.
209		#'
210		#' @param x (`numeric`)\cr vector.
211		#'
212		#' @return An empty `numeric`.
213		#'
214		#' @examples
215		#' x <- c(NA, NA, NA)
216		#' # Internal function - empty_vector_if_na
217		#' \dontrun{
218		#' empty_vector_if_na(x)
219		#' }
220		#'
221		#' @keywords internal
222		empty_vector_if_na <- function(x) {
223	137x	if (all(is.na(x))) {
224	27x	numeric()
225		} else {
226	110x	x
227		}
228		}
229
230		#' Combine Two Vectors Element Wise
231		#'
232		#' @param x (`vector`)\cr first vector to combine.
233		#' @param y (`vector`)\cr second vector to combine.
234		#'
235		#' @return A `list` where each element combines corresponding elements of `x` and `y`.
236		#'
237		#' @examples
238		#' combine_vectors(1:3, 4:6)
239		#'
240		#' @export
241		combine_vectors <- function(x, y) {
242	49x	checkmate::assert_vector(x)
243	49x	checkmate::assert_vector(y, len = length(x))
244
245	49x	result <- lapply(as.data.frame(rbind(x, y)), `c`)
246	49x	names(result) <- NULL
247	49x	result
248		}
249
250		#' Extract Elements by Name
251		#'
252		#' @description
253		#'
254		#' This utility function extracts elements from a vector `x` by `names`.
255		#' Differences to the standard [base::`[`()] function are:
256		#'
257		#' - If `x` is `NULL`, then still always `NULL` is returned (same as in base function).
258		#' - If `x` is not `NULL`, then the intersection of its names is made with `names` and those
259		#' elements are returned. That is, `names` which don't appear in `x` are not returned as `NA`s.
260		#'
261		#' @param x (named `vector`)\cr where to extract named elements from.
262		#' @param names (`character`)\cr vector of names to extract.
263		#'
264		#' @return Either `NULL` or the extracted elements from `x`.
265		#'
266		#' @keywords internal
267		extract_by_name <- function(x, names) {
268	3267x	if (is.null(x)) {
269	2845x	return(NULL)
270		}
271	422x	checkmate::assert_named(x)
272	422x	checkmate::assert_character(names)
273	422x	which_extract <- intersect(names(x), names)
274	422x	if (length(which_extract) > 0) {
275	202x	x[which_extract]
276		} else {
277	220x	NULL
278		}
279		}
280
281		#' Labels for Adverse Event Baskets
282		#'
283		#' @description `r lifecycle::badge("stable")`
284		#' @param aesi (`character`)\cr with standardized MedDRA query name (e.g. `SMQzzNAM`) or customized query
285		#' name (e.g. `CQzzNAM`).
286		#' @param scope (`character`)\cr with scope of query (e.g. `SMQzzSC`).
287		#'
288		#' @return A `string` with the standard label for the AE basket.
289		#'
290		#' @export
291		#'
292		#' @examples
293		#' adae <- tern_ex_adae
294		#'
295		#' # Standardized query label includes scope.
296		#' aesi_label(adae$SMQ01NAM, scope = adae$SMQ01SC)
297		#'
298		#' # Customized query label.
299		#' aesi_label(adae$CQ01NAM)
300		aesi_label <- function(aesi, scope = NULL) {
301	3x	checkmate::assert_character(aesi)
302	3x	checkmate::assert_character(scope, null.ok = TRUE)
303	3x	aesi_label <- obj_label(aesi)
304	3x	aesi <- sas_na(aesi)
305	3x	aesi <- unique(aesi)[!is.na(unique(aesi))]
306
307	3x	lbl <- if (length(aesi) == 1 && !is.null(scope)) {
308	1x	scope <- sas_na(scope)
309	1x	scope <- unique(scope)[!is.na(unique(scope))]
310	1x	checkmate::assert_string(scope)
311	1x	paste0(aesi, " (", scope, ")")
312	3x	} else if (length(aesi) == 1 && is.null(scope)) {
313	1x	aesi
314		} else {
315	1x	aesi_label
316		}
317
318	3x	lbl
319		}
320
321		#' Indicate Study Arm Variable in Formula
322		#'
323		#' @description
324		#'
325		#' We use `study_arm` to indicate the study arm variable in `tern` formulas.
326		#'
327		#' @param x arm information
328		#'
329		#' @keywords internal
330		#'
331		study_arm <- function(x) {
332	!	structure(x, varname = deparse(substitute(x)))
333		}
334
335		#' Smooth Function with Optional Grouping
336		#'
337		#' @description `r lifecycle::badge("stable")`
338		#'
339		#' This produces \code{loess} smoothed estimates of `y` with Student confidence intervals.
340		#'
341		#' @param df (`data.frame`)\cr data set containing all analysis variables.
342		#' @param x (`character`)\cr value with x column name.
343		#' @param y (`character`)\cr value with y column name.
344		#' @param groups (`character`)\cr vector with optional grouping variables names.
345		#' @param level (`numeric`)\cr level of confidence interval to use (0.95 by default).
346		#' @return A `data.frame` with original `x`, smoothed `y`, `ylow`, `yhigh` and
347		#' optional `groups` variables formatted to factor type.
348		#' @export
349		#'
350		get_smooths <- function(df, x, y, groups = NULL, level = 0.95) {
351	5x	checkmate::assert_data_frame(df)
352	5x	df_cols <- colnames(df)
353	5x	checkmate::assert_string(x)
354	5x	checkmate::assert_subset(x, df_cols)
355	5x	checkmate::assert_numeric(df[[x]])
356	5x	checkmate::assert_string(y)
357	5x	checkmate::assert_subset(y, df_cols)
358	5x	checkmate::assert_numeric(df[[y]])
359
360	5x	if (!is.null(groups)) {
361	4x	checkmate::assert_character(groups)
362	4x	checkmate::assert_subset(groups, df_cols)
363		}
364
365	5x	smooths <- function(x, y) {
366	18x	stats::predict(stats::loess(y ~ x), se = TRUE)
367		}
368
369	5x	if (!is.null(groups)) {
370	4x	cc <- stats::complete.cases(df[c(x, y, groups)])
371	4x	df_c <- df[cc, c(x, y, groups)]
372	4x	df_c_ordered <- df_c[do.call("order", as.list(df_c[, groups, drop = FALSE])), , drop = FALSE]
373	4x	df_c_g <- data.frame(Map(as.factor, df_c_ordered[groups]))
374
375	4x	df_smooth_raw <-
376	4x	by(df_c_ordered, df_c_g, function(d) {
377	17x	plx <- smooths(d[[x]], d[[y]])
378	17x	data.frame(
379	17x	x = d[[x]],
380	17x	y = plx$fit,
381	17x	ylow = plx$fit - stats::qt(level, plx$df) * plx$se,
382	17x	yhigh = plx$fit + stats::qt(level, plx$df) * plx$se
383		)
384		})
385
386	4x	df_smooth <- do.call(rbind, df_smooth_raw)
387	4x	df_smooth[groups] <- df_c_g
388
389	4x	df_smooth
390		} else {
391	1x	cc <- stats::complete.cases(df[c(x, y)])
392	1x	df_c <- df[cc, ]
393	1x	plx <- smooths(df_c[[x]], df_c[[y]])
394
395	1x	df_smooth <- data.frame(
396	1x	x = df_c[[x]],
397	1x	y = plx$fit,
398	1x	ylow = plx$fit - stats::qt(level, plx$df) * plx$se,
399	1x	yhigh = plx$fit + stats::qt(level, plx$df) * plx$se
400		)
401
402	1x	df_smooth
403		}
404		}
405
406		#' Number of Available (Non-Missing Entries) in a Vector
407		#'
408		#' @description
409		#'
410		#' Small utility function for better readability.
411		#'
412		#' @param x (`any`)\cr vector in which to count non-missing values.
413		#'
414		#' @return Number of non-missing values.
415		#'
416		#' @examples
417		#' # Internal function - n_available
418		#' \dontrun{
419		#' n_available(c(1, NA, 2))
420		#' }
421		#'
422		#' @keywords internal
423		n_available <- function(x) {
424	208x	sum(!is.na(x))
425		}
426
427		#' Reapply Variable Labels
428		#'
429		#' @description This is a helper function that is used in tests.
430		#'
431		#' @param x (`vector`)\cr vector of elements that needs new labels.
432		#' @param varlabels (`character`)\cr vector of labels for `x`.
433		#' @param ... further parameters to be added to the list.
434		#'
435		#' @export
436		reapply_varlabels <- function(x, varlabels, ...) {
437	10x	named_labels <- c(as.list(varlabels), list(...))
438	10x	formatters::var_labels(x)[names(named_labels)] <- as.character(named_labels)
439	10x	x
440		}
441
442		# Wrapper function of survival::clogit so that when model fitting failed, a more useful message would show
443		clogit_with_tryCatch <- function(formula, data, ...) { # nolint
444	30x	tryCatch(
445	30x	survival::clogit(formula = formula, data = data, ...),
446	30x	error = function(e) stop("model not built successfully with survival::clogit")
447		)
448		}

1		#' Count Patients with Marked Laboratory Abnormalities
2		#'
3		#' @description `r lifecycle::badge("stable")`
4		#'
5		#' Primary analysis variable `.var` indicates whether single, replicated
6		#' or last marked laboratory abnormality was observed (factor).
7		#' Additional analysis variables are `id` (character or factor) and `direction` indicating
8		#' the direction of the abnormality (factor).
9		#' Denominator is number of patients with at least one valid measurement during
10		#' * For `Single, not last` and `Last or replicated`: Numerator is number of patients
11		#' with `Single, not last` and `Last or replicated` levels, respectively.
12		#' * For `Any`: Numerator is the number of patients with either single or
13		#' replicated marked abnormalities.
14		#'
15		#' @details Note that `Single, not last` and `Last or replicated` levels are
16		#' mutually exclusive. If a patient has abnormalities that meet both the `Single, not last`
17		#' and `Last or replicated` criteria, then the patient will be counted only under the `Last or replicated` category.
18		#'
19		#' @inheritParams argument_convention
20		#' @param category (`list`)\cr with different marked category names for single
21		#' and last or replicated.
22		#'
23		#' @name abnormal_by_marked
24		NULL
25
26		#' @describeIn abnormal_by_marked Statistics function which returns
27		#' the counts and fractions of patients with `Single, not last`, `Last or replicated` and `Any`
28		#' marked laboratory abnormalities for a single `abnormal` level.
29		#'
30		#' @return [s_count_abnormal_by_marked()] the single statistic `count_fraction`
31		#' with `Single, not last`, `Last or replicated` and `Any` results.
32		#'
33		#' @examples
34		#' library(dplyr)
35		#'
36		#' df <- data.frame(
37		#' USUBJID = as.character(c(rep(1, 5), rep(2, 5), rep(1, 5), rep(2, 5))),
38		#' ARMCD = factor(c(rep("ARM A", 5), rep("ARM B", 5), rep("ARM A", 5), rep("ARM B", 5))),
39		#' ANRIND = factor(c(
40		#' "NORMAL", "HIGH", "HIGH", "HIGH HIGH", "HIGH",
41		#' "HIGH", "HIGH", "HIGH HIGH", "NORMAL", "HIGH HIGH", "NORMAL", "LOW", "LOW", "LOW LOW", "LOW",
42		#' "LOW", "LOW", "LOW LOW", "NORMAL", "LOW LOW"
43		#' )),
44		#' ONTRTFL = rep(c("", "Y", "Y", "Y", "Y", "Y", "Y", "Y", "Y", "Y"), 2),
45		#' PARAMCD = factor(c(rep("CRP", 10), rep("ALT", 10))),
46		#' AVALCAT1 = factor(rep(c("", "", "", "SINGLE", "REPLICATED", "", "", "LAST", "", "SINGLE"), 2)),
47		#' stringsAsFactors = FALSE
48		#' )
49		#'
50		#' df <- df %>%
51		#' mutate(abn_dir = factor(
52		#' case_when(
53		#' ANRIND == "LOW LOW" ~ "Low",
54		#' ANRIND == "HIGH HIGH" ~ "High",
55		#' TRUE ~ ""
56		#' ),
57		#' levels = c("Low", "High")
58		#' ))
59		#'
60		#' # Select only post-baseline records.
61		#' df <- df %>% filter(ONTRTFL == "Y")
62		#' df_crp <- df %>%
63		#' filter(PARAMCD == "CRP") %>%
64		#' droplevels()
65		#' full_parent_df <- list(df_crp, "not_needed")
66		#' cur_col_subset <- list(rep(TRUE, nrow(df_crp)), "not_needed")
67		#' spl_context <- data.frame(
68		#' split = c("PARAMCD", "GRADE_DIR"),
69		#' full_parent_df = I(full_parent_df),
70		#' cur_col_subset = I(cur_col_subset)
71		#' )
72		#' # Internal function - s_count_abnormal_by_marked
73		#' \dontrun{
74		#' s_count_abnormal_by_marked(
75		#' df = df_crp %>% filter(abn_dir == "High"),
76		#' .spl_context = spl_context,
77		#' .var = "AVALCAT1",
78		#' variables = list(id = "USUBJID", param = "PARAMCD", direction = "abn_dir")
79		#' )
80		#' }
81		#'
82		#' @keywords internal
83		s_count_abnormal_by_marked <- function(df,
84		.var = "AVALCAT1",
85		.spl_context,
86		category = list(single = "SINGLE", last_replicated = c("LAST", "REPLICATED")),
87		variables = list(id = "USUBJID", param = "PARAM", direction = "abn_dir")) {
88	3x	checkmate::assert_string(.var)
89	3x	checkmate::assert_list(variables)
90	3x	checkmate::assert_list(category)
91	3x	checkmate::assert_subset(names(category), c("single", "last_replicated"))
92	3x	checkmate::assert_subset(names(variables), c("id", "param", "direction"))
93	3x	checkmate::assert_vector(unique(df[[variables$direction]]), max.len = 1)
94
95	2x	assert_df_with_variables(df, c(aval = .var, variables))
96	2x	checkmate::assert_multi_class(df[[.var]], classes = c("factor", "character"))
97	2x	checkmate::assert_multi_class(df[[variables$id]], classes = c("factor", "character"))
98
99
100	2x	first_row <- .spl_context[.spl_context$split == variables[["param"]], ] # nolint
101		# Patients in the denominator have at least one post-baseline visit.
102	2x	subj <- first_row$full_parent_df[[1]][[variables[["id"]]]]
103	2x	subj_cur_col <- subj[first_row$cur_col_subset[[1]]]
104		# Some subjects may have a record for high and low directions but
105		# should be counted only once.
106	2x	denom <- length(unique(subj_cur_col))
107
108	2x	if (denom != 0) {
109	2x	subjects_last_replicated <- unique(
110	2x	df[df[[.var]] %in% category[["last_replicated"]], variables$id, drop = TRUE]
111		)
112	2x	subjects_single <- unique(
113	2x	df[df[[.var]] %in% category[["single"]], variables$id, drop = TRUE]
114		)
115		# Subjects who have both single and last/replicated abnormalities are counted in only the last/replicated group.
116	2x	subjects_single <- setdiff(subjects_single, subjects_last_replicated)
117	2x	n_single <- length(subjects_single)
118	2x	n_last_replicated <- length(subjects_last_replicated)
119	2x	n_any <- n_single + n_last_replicated
120	2x	result <- list(count_fraction = list(
121	2x	"Single, not last" = c(n_single, n_single / denom),
122	2x	"Last or replicated" = c(n_last_replicated, n_last_replicated / denom),
123	2x	"Any Abnormality" = c(n_any, n_any / denom)
124		))
125		} else {
126	!	result <- list(count_fraction = list(
127	!	"Single, not last" = c(0, 0),
128	!	"Last or replicated" = c(0, 0),
129	!	"Any Abnormality" = c(0, 0)
130		))
131		}
132
133	2x	result
134		}
135
136		#' @describeIn abnormal_by_marked Formatted Analysis function which can be further customized by calling
137		#' [rtables::make_afun()] on it. It is used as `afun` in [rtables::analyze()].
138		#'
139		#' @return [a_count_abnormal_by_marked()] returns the corresponding list with formatted [rtables::CellValue()].
140		#'
141		#' @examples
142		#' # Internal function - a_count_abnormal_by_marked
143		#' \dontrun{
144		#' # Use the Formatted Analysis function for `analyze()`. We need to ungroup `count_fraction` first
145		#' # so that the `rtables` formatting function `format_count_fraction()` can be applied correctly.
146		#' afun <- make_afun(a_count_abnormal_by_marked, .ungroup_stats = "count_fraction")
147		#' afun(
148		#' df = df_crp %>% filter(abn_dir == "High"),
149		#' .spl_context = spl_context,
150		#' variables = list(id = "USUBJID", param = "PARAMCD", direction = "abn_dir")
151		#' )
152		#' }
153		#'
154		#' @keywords internal
155		a_count_abnormal_by_marked <- make_afun(
156		s_count_abnormal_by_marked,
157		.formats = c(count_fraction = format_count_fraction)
158		)
159
160		#' @describeIn abnormal_by_marked Layout creating function which can be used for creating tables,
161		#' which can take statistics function arguments and additional format arguments (see below).
162		#'
163		#' @examples
164		#' map <- unique(
165		#' df[df$abn_dir %in% c("Low", "High") & df$AVALCAT1 != "", c("PARAMCD", "abn_dir")]
166		#' ) %>%
167		#' lapply(as.character) %>%
168		#' as.data.frame() %>%
169		#' arrange(PARAMCD, abn_dir)
170		#'
171		#' basic_table() %>%
172		#' split_cols_by("ARMCD") %>%
173		#' split_rows_by("PARAMCD") %>%
174		#' summarize_num_patients(
175		#' var = "USUBJID",
176		#' .stats = "unique_count"
177		#' ) %>%
178		#' split_rows_by(
179		#' "abn_dir",
180		#' split_fun = trim_levels_to_map(map)
181		#' ) %>%
182		#' count_abnormal_by_marked(
183		#' var = "AVALCAT1",
184		#' variables = list(
185		#' id = "USUBJID",
186		#' param = "PARAMCD",
187		#' direction = "abn_dir"
188		#' )
189		#' ) %>%
190		#' build_table(df = df)
191		#'
192		#'
193		#' basic_table() %>%
194		#' split_cols_by("ARMCD") %>%
195		#' split_rows_by("PARAMCD") %>%
196		#' summarize_num_patients(
197		#' var = "USUBJID",
198		#' .stats = "unique_count"
199		#' ) %>%
200		#' split_rows_by(
201		#' "abn_dir",
202		#' split_fun = trim_levels_in_group("abn_dir")
203		#' ) %>%
204		#' count_abnormal_by_marked(
205		#' var = "AVALCAT1",
206		#' variables = list(
207		#' id = "USUBJID",
208		#' param = "PARAMCD",
209		#' direction = "abn_dir"
210		#' )
211		#' ) %>%
212		#' build_table(df = df)
213		#'
214		#' @export
215		count_abnormal_by_marked <- function(lyt,
216		var,
217		...,
218		.stats = NULL,
219		.formats = NULL,
220		.labels = NULL,
221		.indent_mods = NULL) {
222	1x	checkmate::assert_string(var)
223
224	1x	afun <- make_afun(
225	1x	a_count_abnormal_by_marked,
226	1x	.stats = .stats,
227	1x	.formats = .formats,
228	1x	.labels = .labels,
229	1x	.indent_mods = .indent_mods,
230	1x	.ungroup_stats = "count_fraction"
231		)
232
233	1x	lyt <- analyze(
234	1x	lyt = lyt,
235	1x	vars = var,
236	1x	afun = afun,
237	1x	show_labels = "hidden",
238	1x	extra_args = c(list(...))
239		)
240	1x	lyt
241		}

1		#' Patient Counts with Abnormal Range Values by Baseline Status
2		#'
3		#' @description `r lifecycle::badge("stable")`
4		#'
5		#' @details
6		#' Note that `df` should be filtered to include only post-baseline records.
7		#'
8		#' Primary analysis variable `.var` indicates the abnormal range result (character or factor), and additional
9		#' analysis variables are `id` (character or factor) and `baseline` (character or factor). For each
10		#' direction specified in `abnormal` (e.g. high or low) we condition on baseline range result and count
11		#' patients in the numerator and denominator as follows:
12		#' * `Not <Abnormal>`
13		#' * `denom`: the number of patients without abnormality at baseline (excluding those with missing baseline)
14		#' * `num`: the number of patients in `denom` who also have at least one abnormality post-baseline
15		#' * `<Abnormal>`
16		#' * `denom`: the number of patients with abnormality at baseline
17		#' * `num`: the number of patients in `denom` who also have at least one abnormality post-baseline
18		#' * `Total`
19		#' * `denom`: the number of patients with at least one valid measurement post-baseline
20		#' * `num`: the number of patients in `denom` who also have at least one abnormality post-baseline
21		#'
22		#' @inheritParams argument_convention
23		#' @param abnormal (`character`)\cr identifying the abnormal range level(s) in `.var`.
24		#' @seealso Relevant description function [d_count_abnormal_by_baseline()].
25		#'
26		#' @name abnormal_by_baseline
27		#' @include formats.R
28		NULL
29
30		#' Description Function for [s_count_abnormal_by_baseline()]
31		#'
32		#' @description `r lifecycle::badge("stable")`
33		#'
34		#' Description function that produces the labels for [s_count_abnormal_by_baseline()].
35		#'
36		#' @inheritParams abnormal_by_baseline
37		#'
38		#' @examples
39		#' d_count_abnormal_by_baseline("LOW")
40		#'
41		#' @export
42		d_count_abnormal_by_baseline <- function(abnormal) {
43	7x	null_name <- paste0(toupper(substr(abnormal, 1, 1)), tolower(substring(abnormal, 2)))
44	7x	not_abn_name <- paste("Not", tolower(abnormal), "baseline status")
45	7x	abn_name <- paste(null_name, "baseline status")
46	7x	total_name <- "Total"
47
48	7x	list(
49	7x	not_abnormal = not_abn_name,
50	7x	abnormal = abn_name,
51	7x	total = total_name
52		)
53		}
54
55		#' @describeIn abnormal_by_baseline For a single `abnormal` level, produce a statistic `fraction` which is
56		#' a named list with 3 elements: `not_abnormal`, `abnormal` and `total`.
57		#' Each element contains a vector with `num` and `denom` counts of patients.
58		#' Please note that if the baseline variable or analysis variable contains `NA`, it is expected that `NA` has been
59		#' conveyed to `na_level` appropriately beforehand with `df_explicit_na()` or `explicit_na()`.
60		#'
61		#' @param na_level (`string`)\cr the explicit `na_level` argument you used in the pre-processing steps (maybe with
62		#' `df_explicit_na()`). The default is `"<Missing>"`.
63		#'
64		#' @examples
65		#' df <- data.frame(
66		#' USUBJID = as.character(c(1:6)),
67		#' ANRIND = factor(c(rep("LOW", 4), "NORMAL", "HIGH")),
68		#' BNRIND = factor(c("LOW", "NORMAL", "HIGH", NA, "LOW", "NORMAL"))
69		#' )
70		#' df <- df_explicit_na(df)
71		#'
72		#' # Internal function - s_count_abnormal_by_baseline
73		#' \dontrun{
74		#' # Just for one abnormal level.
75		#' s_count_abnormal_by_baseline(df, .var = "ANRIND", abnormal = "HIGH")
76		#' }
77		#'
78		#' @keywords internal
79		s_count_abnormal_by_baseline <- function(df,
80		.var,
81		abnormal,
82		na_level = "<Missing>",
83		variables = list(id = "USUBJID", baseline = "BNRIND")) {
84	5x	checkmate::assert_string(.var)
85	5x	checkmate::assert_string(abnormal)
86	5x	checkmate::assert_string(na_level)
87	5x	assert_df_with_variables(df, c(range = .var, variables))
88	5x	checkmate::assert_subset(names(variables), c("id", "baseline"))
89	5x	checkmate::assert_multi_class(df[[variables$id]], classes = c("factor", "character"))
90	5x	checkmate::assert_multi_class(df[[variables$baseline]], classes = c("factor", "character"))
91	5x	checkmate::assert_multi_class(df[[.var]], classes = c("factor", "character"))
92
93		# If input is passed as character, changed to factor
94	5x	df[[.var]] <- as_factor_keep_attributes(df[[.var]], na_level = na_level)
95	5x	df[[variables$baseline]] <- as_factor_keep_attributes(df[[variables$baseline]], na_level = na_level)
96
97	5x	assert_valid_factor(df[[.var]], any.missing = FALSE)
98	4x	assert_valid_factor(df[[variables$baseline]], any.missing = FALSE)
99
100		# Keep only records with valid analysis value.
101	3x	df <- df[df[[.var]] != na_level, ]
102
103	3x	anl <- data.frame(
104	3x	id = df[[variables$id]],
105	3x	var = df[[.var]],
106	3x	baseline = df[[variables$baseline]],
107	3x	stringsAsFactors = FALSE
108		)
109
110		# Total:
111		# - Patients in denominator: have at least one valid measurement post-baseline.
112		# - Patients in numerator: have at least one abnormality.
113	3x	total_denom <- length(unique(anl$id))
114	3x	total_num <- length(unique(anl$id[anl$var == abnormal]))
115
116		# Baseline NA records are counted only in total rows.
117	3x	anl <- anl[anl$baseline != na_level, ]
118
119		# Abnormal:
120		# - Patients in denominator: have abnormality at baseline.
121		# - Patients in numerator: have abnormality at baseline AND
122		# have at least one abnormality post-baseline.
123	3x	abn_denom <- length(unique(anl$id[anl$baseline == abnormal]))
124	3x	abn_num <- length(unique(anl$id[anl$baseline == abnormal & anl$var == abnormal]))
125
126		# Not abnormal:
127		# - Patients in denominator: do not have abnormality at baseline.
128		# - Patients in numerator: do not have abnormality at baseline AND
129		# have at least one abnormality post-baseline.
130	3x	not_abn_denom <- length(unique(anl$id[anl$baseline != abnormal]))
131	3x	not_abn_num <- length(unique(anl$id[anl$baseline != abnormal & anl$var == abnormal]))
132
133	3x	labels <- d_count_abnormal_by_baseline(abnormal)
134	3x	list(fraction = list(
135	3x	not_abnormal = formatters::with_label(c(num = not_abn_num, denom = not_abn_denom), labels$not_abnormal),
136	3x	abnormal = formatters::with_label(c(num = abn_num, denom = abn_denom), labels$abnormal),
137	3x	total = formatters::with_label(c(num = total_num, denom = total_denom), labels$total)
138		))
139		}
140
141		#' @describeIn abnormal_by_baseline Formatted Analysis function which can be further customized by calling
142		#' [rtables::make_afun()] on it. It is used as `afun` in [rtables::analyze()].
143		#'
144		#' @return [a_count_abnormal_by_baseline()] returns the corresponding list with formatted [rtables::CellValue()].
145		#'
146		#' @examples
147		#' # Internal function - a_count_abnormal_by_baseline
148		#' \dontrun{
149		#' # Use the Formatted Analysis function for `analyze()`. We need to ungroup `fraction` first
150		#' # so that the `rtables` formatting function `format_fraction()` can be applied correctly.
151		#' afun <- make_afun(a_count_abnormal_by_baseline, .ungroup_stats = "fraction")
152		#' afun(df, .var = "ANRIND", abnormal = "LOW")
153		#' }
154		#'
155		#' @keywords internal
156		a_count_abnormal_by_baseline <- make_afun(
157		s_count_abnormal_by_baseline,
158		.formats = c(fraction = format_fraction)
159		)
160
161		#' @describeIn abnormal_by_baseline Layout creating function which can be used for creating tables, which can take
162		#' statistics function arguments and additional format arguments (see below).
163		#'
164		#' @inheritParams argument_convention
165		#'
166		#' @examples
167		#' # Layout creating function.
168		#' basic_table() %>%
169		#' count_abnormal_by_baseline(var = "ANRIND", abnormal = c(High = "HIGH")) %>%
170		#' build_table(df)
171		#'
172		#' # Passing of statistics function and formatting arguments.
173		#' df2 <- data.frame(
174		#' ID = as.character(c(1, 2, 3, 4)),
175		#' RANGE = factor(c("NORMAL", "LOW", "HIGH", "HIGH")),
176		#' BLRANGE = factor(c("LOW", "HIGH", "HIGH", "NORMAL"))
177		#' )
178		#'
179		#' basic_table() %>%
180		#' count_abnormal_by_baseline(
181		#' var = "RANGE",
182		#' abnormal = c(Low = "LOW"),
183		#' variables = list(id = "ID", baseline = "BLRANGE"),
184		#' .formats = c(fraction = "xx / xx"),
185		#' .indent_mods = c(fraction = 2L)
186		#' ) %>%
187		#' build_table(df2)
188		#'
189		#' @export
190		count_abnormal_by_baseline <- function(lyt,
191		var,
192		abnormal,
193		...,
194		table_names = abnormal,
195		.stats = NULL,
196		.formats = NULL,
197		.labels = NULL,
198		.indent_mods = NULL) {
199	2x	checkmate::assert_character(abnormal, len = length(table_names), names = "named")
200	2x	checkmate::assert_string(var)
201	2x	afun <- make_afun(
202	2x	a_count_abnormal_by_baseline,
203	2x	.stats = .stats,
204	2x	.formats = .formats,
205	2x	.labels = .labels,
206	2x	.indent_mods = .indent_mods,
207	2x	.ungroup_stats = "fraction"
208		)
209	2x	for (i in seq_along(abnormal)) {
210	4x	abn <- abnormal[i]
211	4x	lyt <- analyze(
212	4x	lyt = lyt,
213	4x	vars = var,
214	4x	var_labels = names(abn),
215	4x	afun = afun,
216	4x	table_names = table_names[i],
217	4x	extra_args = c(list(abnormal = abn), list(...)),
218	4x	show_labels = "visible"
219		)
220		}
221	2x	lyt
222		}

1		#' Stack Multiple Grobs
2		#'
3		#' @description `r lifecycle::badge("stable")`
4		#'
5		#' Stack grobs as a new grob with 1 column and multiple rows layout.
6		#'
7		#' @param ... grobs.
8		#' @param grobs list of grobs.
9		#' @param padding unit of length 1, space between each grob.
10		#' @param vp a \code{\link{viewport}} object (or \code{NULL}).
11		#' @param name a character identifier for the grob.
12		#' @param gp A \code{\link{gpar}} object.
13		#' @export
14		#'
15		#' @examples
16		#' library(grid)
17		#'
18		#' g1 <- circleGrob(gp = gpar(col = "blue"))
19		#' g2 <- circleGrob(gp = gpar(col = "red"))
20		#' g3 <- textGrob("TEST TEXT")
21		#' grid.newpage()
22		#' grid.draw(stack_grobs(g1, g2, g3))
23		#'
24		#' showViewport()
25		#'
26		#' grid.newpage()
27		#' pushViewport(viewport(layout = grid.layout(1, 2)))
28		#' vp1 <- viewport(layout.pos.row = 1, layout.pos.col = 2)
29		#' grid.draw(stack_grobs(g1, g2, g3, vp = vp1, name = "test"))
30		#'
31		#' showViewport()
32		#' grid.ls(grobs = TRUE, viewports = TRUE, print = FALSE)
33		stack_grobs <- function(...,
34		grobs = list(...),
35		padding = grid::unit(2, "line"),
36		vp = NULL,
37		gp = NULL,
38		name = NULL) {
39	4x	checkmate::assert_true(
40	4x	all(vapply(grobs, grid::is.grob, logical(1)))
41		)
42
43	4x	if (length(grobs) == 1) {
44	1x	return(grobs[[1]])
45		}
46
47	3x	n_layout <- 2 * length(grobs) - 1
48	3x	hts <- lapply(
49	3x	seq(1, n_layout),
50	3x	function(i) {
51	39x	if (i %% 2 != 0) {
52	21x	grid::unit(1, "null")
53		} else {
54	18x	padding
55		}
56		}
57		)
58	3x	hts <- do.call(grid::unit.c, hts)
59
60	3x	main_vp <- grid::viewport(
61	3x	layout = grid::grid.layout(nrow = n_layout, ncol = 1, heights = hts)
62		)
63
64	3x	nested_grobs <- Map(function(g, i) {
65	21x	grid::gTree(
66	21x	children = grid::gList(g),
67	21x	vp = grid::viewport(layout.pos.row = i, layout.pos.col = 1)
68		)
69	3x	}, grobs, seq_along(grobs) * 2 - 1)
70
71	3x	grobs_mainvp <- grid::gTree(
72	3x	children = do.call(grid::gList, nested_grobs),
73	3x	vp = main_vp
74		)
75
76	3x	grid::gTree(
77	3x	children = grid::gList(grobs_mainvp),
78	3x	vp = vp,
79	3x	gp = gp,
80	3x	name = name
81		)
82		}
83
84
85		#' Arrange Multiple Grobs
86		#'
87		#' Arrange grobs as a new grob with \verb{nm (rowscols)} layout.
88		#'
89		#' @inheritParams stack_grobs
90		#' @param ncol number of columns in layout.
91		#' @param nrow number of rows in layout.
92		#' @param padding_ht unit of length 1, vertical space between each grob.
93		#' @param padding_wt unit of length 1, horizontal space between each grob.
94		#'
95		#' @examples
96		#' library(grid)
97		#'
98		#' # Internal function - arrange_grobs
99		#' \dontrun{
100		#' num <- lapply(1:9, textGrob)
101		#' grid::grid.newpage()
102		#' grid.draw(arrange_grobs(grobs = num, ncol = 2))
103		#'
104		#' showViewport()
105		#'
106		#' g1 <- circleGrob(gp = gpar(col = "blue"))
107		#' g2 <- circleGrob(gp = gpar(col = "red"))
108		#' g3 <- textGrob("TEST TEXT")
109		#' grid::grid.newpage()
110		#' grid.draw(arrange_grobs(g1, g2, g3, nrow = 2))
111		#'
112		#' showViewport()
113		#'
114		#' grid::grid.newpage()
115		#' grid.draw(arrange_grobs(g1, g2, g3, ncol = 3))
116		#'
117		#' grid::grid.newpage()
118		#' grid::pushViewport(grid::viewport(layout = grid::grid.layout(1, 2)))
119		#' vp1 <- grid::viewport(layout.pos.row = 1, layout.pos.col = 2)
120		#' grid.draw(arrange_grobs(g1, g2, g3, ncol = 2, vp = vp1))
121		#'
122		#' showViewport()
123		#' }
124		#'
125		#' @keywords internal
126		arrange_grobs <- function(..., # nolint
127		grobs = list(...),
128		ncol = NULL, nrow = NULL,
129		padding_ht = grid::unit(2, "line"),
130		padding_wt = grid::unit(2, "line"),
131		vp = NULL,
132		gp = NULL,
133		name = NULL) {
134	5x	checkmate::assert_true(
135	5x	all(vapply(grobs, grid::is.grob, logical(1)))
136		)
137
138	5x	if (length(grobs) == 1) {
139	1x	return(grobs[[1]])
140		}
141
142	4x	if (is.null(ncol) && is.null(nrow)) {
143	1x	ncol <- 1
144	1x	nrow <- ceiling(length(grobs) / ncol)
145	3x	} else if (!is.null(ncol) && is.null(nrow)) {
146	1x	nrow <- ceiling(length(grobs) / ncol)
147	2x	} else if (is.null(ncol) && !is.null(nrow)) {
148	!	ncol <- ceiling(length(grobs) / nrow)
149		}
150
151	4x	if (ncol * nrow < length(grobs)) {
152	1x	stop("specififed ncol and nrow are not enough for arranging the grobs ")
153		}
154
155	3x	if (ncol == 1) {
156	2x	return(stack_grobs(grobs = grobs, padding = padding_ht, vp = vp, gp = gp, name = name))
157		}
158
159	1x	n_col <- 2 * ncol - 1
160	1x	n_row <- 2 * nrow - 1
161	1x	hts <- lapply(
162	1x	seq(1, n_row),
163	1x	function(i) {
164	5x	if (i %% 2 != 0) {
165	3x	grid::unit(1, "null")
166		} else {
167	2x	padding_ht
168		}
169		}
170		)
171	1x	hts <- do.call(grid::unit.c, hts)
172
173	1x	wts <- lapply(
174	1x	seq(1, n_col),
175	1x	function(i) {
176	5x	if (i %% 2 != 0) {
177	3x	grid::unit(1, "null")
178		} else {
179	2x	padding_wt
180		}
181		}
182		)
183	1x	wts <- do.call(grid::unit.c, wts)
184
185	1x	main_vp <- grid::viewport(
186	1x	layout = grid::grid.layout(nrow = n_row, ncol = n_col, widths = wts, heights = hts)
187		)
188
189	1x	nested_grobs <- list()
190	1x	k <- 0
191	1x	for (i in seq(nrow) * 2 - 1) {
192	3x	for (j in seq(ncol) * 2 - 1) {
193	9x	k <- k + 1
194	9x	if (k <= length(grobs)) {
195	9x	nested_grobs <- c(
196	9x	nested_grobs,
197	9x	list(grid::gTree(
198	9x	children = grid::gList(grobs[[k]]),
199	9x	vp = grid::viewport(layout.pos.row = i, layout.pos.col = j)
200		))
201		)
202		}
203		}
204		}
205	1x	grobs_mainvp <- grid::gTree(
206	1x	children = do.call(grid::gList, nested_grobs),
207	1x	vp = main_vp
208		)
209
210	1x	grid::gTree(
211	1x	children = grid::gList(grobs_mainvp),
212	1x	vp = vp,
213	1x	gp = gp,
214	1x	name = name
215		)
216		}
217
218
219
220		#' Draw `grob`
221		#'
222		#' @description `r lifecycle::badge("stable")`
223		#'
224		#' Draw grob on device page.
225		#'
226		#' @param grob grid object
227		#' @param newpage draw on a new page
228		#' @param vp a \code{\link{viewport}} object (or \code{NULL}).
229		#' @export
230		#'
231		#' @examples
232		#' library(dplyr)
233		#' library(grid)
234		#'
235		#' # Internal function - arrange_grob
236		#' \dontrun{
237		#' rect <- rectGrob(width = grid::unit(0.5, "npc"), height = grid::unit(0.5, "npc"))
238		#' rect %>% draw_grob(vp = grid::viewport(angle = 45))
239		#'
240		#' num <- lapply(1:10, textGrob)
241		#' num %>%
242		#' arrange_grobs(grobs = .) %>%
243		#' draw_grob()
244		#' showViewport()
245		#' }
246		draw_grob <- function(grob, newpage = TRUE, vp = NULL) {
247	3x	if (newpage) {
248	3x	grid::grid.newpage()
249		}
250	3x	if (!is.null(vp)) {
251	1x	grid::pushViewport(vp)
252		}
253	3x	grid::grid.draw(grob)
254		}
255
256		tern_grob <- function(x) { # nolint
257	!	class(x) <- unique(c("ternGrob", class(x)))
258	!	x
259		}
260
261		print.ternGrob <- function(x, ...) { # nolint
262	!	grid::grid.newpage()
263	!	grid::grid.draw(x)
264		}

1		#' Assign Footnotes
2		#'
3		#' @description `r lifecycle::badge("deprecated")`
4		#'
5		#' Assign value to attribute footnote of object `x`.
6		#'
7		#' This function is deprecated and will be removed from `tern` in version 0.7.11.
8		#' Please use the equivalent implementation from `rtables` or `attr(x, "footnote")` directly.
9		#'
10		#' @param x an object
11		#' @param value character vector
12		#' @export
13		#' @examples
14		#' x <- table(iris$Species)
15		#' footnotes(x) <- "Species are equally distributed"
16		#' attributes(x)
17		`footnotes<-` <- function(x, value = NULL) { # nolint
18	3x	dep_msg <- 'Please use current implementation in rtables or directly attr(x, "footnote")'
19	3x	lifecycle::deprecate_warn("0.7.11", "footnotes()", details = dep_msg)
20	3x	attr(x, "footnote") <- value
21	3x	x
22		}
23
24		#' Retrieve Footnotes
25		#'
26		#' @description `r lifecycle::badge("deprecated")`
27		#'
28		#' Retrieve value from attribute `footnote` of object `x`.
29		#'
30		#' This function is deprecated and will be removed from `tern` in version 0.7.11.
31		#' Please use the equivalent implementation from `rtables` or `attr(x, "footnote")` directly.
32		#'
33		#' @param x an object
34		#' @export
35		#' @examples
36		#' x <- table(iris$Species)
37		#' footnotes(x) <- "Species are equally distributed"
38		#' footnotes(x)
39		footnotes <- function(x) {
40	3x	dep_msg <- 'Please use current implementation in rtables or directly attr(x, "footnote")'
41	3x	lifecycle::deprecate_warn("0.7.11", "footnotes()", details = dep_msg)
42	3x	attr(x, "footnote")
43		}
44
45		#' Add Footnotes
46		#'
47		#' @description `r lifecycle::badge("deprecated")`
48		#'
49		#' This adds more footnotes.
50		#'
51		#' This function is deprecated and will be removed from `tern` in version 0.7.11.
52		#' Please use the equivalent implementation from `rtables` or `attr(x, "footnote")` directly.
53		#'
54		#' @param x an object
55		#' @param value character vector
56		#' @export
57		#' @examples
58		#' x <- table(iris$Species)
59		#' footnotes(x) <- "Species are equally distributed"
60		#' footnotes(x)
61		#' add_footnotes(x) <- "Add more footnotes"
62		#' footnotes(x)
63		`add_footnotes<-` <- function(x, value) { # nolint
64	1x	dep_msg <- 'Please use current implementation in rtables or directly attr(x, "footnote")'
65	1x	lifecycle::deprecate_warn("0.7.11", "add_footnotes()", details = dep_msg)
66	1x	footnotes(x) <- c(footnotes(x), value)
67	1x	x
68		}

1		#' Combine Factor Levels
2		#'
3		#' @description `r lifecycle::badge("stable")`
4		#'
5		#' Combine specified old factor Levels in a single new level.
6		#'
7		#' @param x factor
8		#' @param levels level names to be combined
9		#' @param new_level name of new level
10		#'
11		#' @return a factor
12		#'
13		#' @export
14		#'
15		#' @examples
16		#' x <- factor(letters[1:5], levels = letters[5:1])
17		#' combine_levels(x, levels = c("a", "b"))
18		#'
19		#' combine_levels(x, c("e", "b"))
20		combine_levels <- function(x, levels, new_level = paste(levels, collapse = "/")) {
21	4x	checkmate::assert_factor(x)
22	4x	checkmate::assert_subset(levels, levels(x))
23
24	4x	lvls <- levels(x)
25
26	4x	lvls[lvls %in% levels] <- new_level
27
28	4x	levels(x) <- lvls
29
30	4x	x
31		}
32
33		#' Conversion of a Vector to a Factor
34		#'
35		#' Converts `x` to a factor and keeps its attributes. Warns appropriately such that the user
36		#' can decide whether they prefer converting to factor manually (e.g. for full control of
37		#' factor levels).
38		#'
39		#' @param x (`atomic`)\cr object to convert.
40		#' @param x_name (`string`)\cr name of `x`.
41		#' @param na_level (`string`)\cr the explicit missing level which should be used when
42		#' converting a character vector.
43		#' @param verbose defaults to `TRUE`. It prints out warnings and messages.
44		#'
45		#' @return The factor with same attributes (except class) as `x`. Does not do any modifications
46		#' if `x` is already a factor.
47		#'
48		#' @examples
49		#' # Internal function - as_factor_keep_attributes
50		#' \dontrun{
51		#' as_factor_keep_attributes(formatters::with_label(c(1, 1, 2, 3), "id"), verbose = FALSE)
52		#' as_factor_keep_attributes(c("a", "b", ""), "id", verbose = FALSE)
53		#' }
54		#'
55		#' @keywords internal
56		as_factor_keep_attributes <- function(x,
57		x_name = deparse(substitute(x)),
58		na_level = "<Missing>",
59		verbose = TRUE) {
60	159x	checkmate::assert_atomic(x)
61	159x	checkmate::assert_string(x_name)
62	159x	checkmate::assert_string(na_level)
63	159x	checkmate::assert_flag(verbose)
64	159x	if (is.factor(x)) {
65	144x	return(x)
66		}
67	15x	x_class <- class(x)[1]
68	15x	if (verbose) {
69	15x	warning(paste(
70	15x	"automatically converting", x_class, "variable", x_name,
71	15x	"to factor, better manually convert to factor to avoid failures"
72		))
73		}
74	15x	if (identical(length(x), 0L)) {
75	1x	warning(paste(
76	1x	x_name, "has length 0, this can lead to tabulation failures, better convert to factor"
77		))
78		}
79	15x	if (is.character(x)) {
80	15x	x_no_na <- explicit_na(sas_na(x), label = na_level)
81	15x	if (any(na_level %in% x_no_na)) {
82	3x	do.call(
83	3x	structure,
84	3x	c(
85	3x	list(.Data = forcats::fct_relevel(x_no_na, na_level, after = Inf)),
86	3x	attributes(x)
87		)
88		)
89		} else {
90	12x	do.call(structure, c(list(.Data = as.factor(x)), attributes(x)))
91		}
92		} else {
93	!	do.call(structure, c(list(.Data = as.factor(x)), attributes(x)))
94		}
95		}
96
97		#' Labels for Bins in Percent
98		#'
99		#' This creates labels for quantile based bins in percent. This assumes the right-closed
100		#' intervals as produced by [cut_quantile_bins()].
101		#'
102		#' @param probs (`proportion` vector)\cr the probabilities identifying the quantiles.
103		#' This is a sorted vector of unique `proportion` values, i.e. between 0 and 1, where
104		#' the boundaries 0 and 1 must not be included.
105		#' @param digits (`integer`)\cr number of decimal places to round the percent numbers.
106		#'
107		#' @return Character vector with labels in the format `[0%,20%]`, `(20%,50%]`, etc.
108		#'
109		#' @examples
110		#' # Internal function - bins_percent_labels
111		#' \dontrun{
112		#' # Just pass the internal probability bounds, then 0 and 100% will be added automatically.
113		#' bins_percent_labels(c(0.2, 0.5))
114		#'
115		#' # Determine how to round.
116		#' bins_percent_labels(0.35224, digits = 1)
117		#'
118		#' # Passing an empty vector just gives a single bin 0-100%.
119		#' bins_percent_labels(c(0, 1))
120		#' }
121		#'
122		#' @keywords internal
123		bins_percent_labels <- function(probs,
124		digits = 0) {
125	1x	if (isFALSE(0 %in% probs)) probs <- c(0, probs)
126	1x	if (isFALSE(1 %in% probs)) probs <- c(probs, 1)
127	8x	checkmate::assert_numeric(probs, lower = 0, upper = 1, unique = TRUE, sorted = TRUE)
128	8x	percent <- round(probs * 100, digits = digits)
129	8x	left <- paste0(utils::head(percent, -1), "%")
130	8x	right <- paste0(utils::tail(percent, -1), "%")
131	8x	without_left_bracket <- paste0(left, ",", right, "]")
132	8x	with_left_bracket <- paste0("[", utils::head(without_left_bracket, 1))
133	8x	if (length(without_left_bracket) > 1) {
134	6x	with_left_bracket <- c(
135	6x	with_left_bracket,
136	6x	paste0("(", utils::tail(without_left_bracket, -1))
137		)
138		}
139	8x	with_left_bracket
140		}
141
142		#' Cutting Numeric Vector into Empirical Quantile Bins
143		#'
144		#' @description `r lifecycle::badge("stable")`
145		#'
146		#' This cuts a numeric vector into sample quantile bins. Note that the intervals are closed on
147		#' the right side. That is, the first bin is the interval `[-Inf, q1]` where `q1` is
148		#' the first quantile, the second bin is then `(q1, q2]`, etc., and the last bin
149		#' is `(qn, +Inf]` where `qn` is the last quantile.
150		#'
151		#' @inheritParams bins_percent_labels
152		#' @param x (`numeric`)\cr the continuous variable values which should be cut into
153		#' quantile bins. This may contain `NA` values, which are then
154		#' not used for the quantile calculations, but included in the return vector.
155		#' @param labels (`character`)\cr the unique labels for the quantile bins. When there are `n`
156		#' probabilities in `probs`, then this must be `n + 1` long.
157		#' @param type (`integer`)\cr type of quantiles to use, see [stats::quantile()] for details.
158		#' @param ordered (`flag`)\cr should the result be an ordered factor.
159		#'
160		#' @return The factor variable with the appropriately labeled bins as levels.
161		#' @export
162		#'
163		#' @examples
164		#' # Default is to cut into quartile bins.
165		#' cut_quantile_bins(cars$speed)
166		#'
167		#' # Use custom quantiles.
168		#' cut_quantile_bins(cars$speed, probs = c(0.1, 0.2, 0.6, 0.88))
169		#'
170		#' # Use custom labels.
171		#' cut_quantile_bins(cars$speed, labels = paste0("Q", 1:4))
172		#'
173		#' # NAs are preserved in result factor.
174		#' ozone_binned <- cut_quantile_bins(airquality$Ozone)
175		#' which(is.na(ozone_binned))
176		#' # So you might want to make these explicit.
177		#' explicit_na(ozone_binned)
178		cut_quantile_bins <- function(x,
179		probs = c(0.25, 0.5, 0.75),
180		labels = NULL,
181		type = 7,
182		ordered = TRUE) {
183	8x	checkmate::assert_flag(ordered)
184	8x	checkmate::assert_numeric(x)
185	7x	if (isFALSE(0 %in% probs)) probs <- c(0, probs)
186	7x	if (isFALSE(1 %in% probs)) probs <- c(probs, 1)
187	8x	checkmate::assert_numeric(probs, lower = 0, upper = 1, unique = TRUE, sorted = TRUE)
188	7x	if (is.null(labels)) labels <- bins_percent_labels(probs)
189	8x	checkmate::assert_character(labels, len = length(probs) - 1, any.missing = FALSE, unique = TRUE)
190
191	8x	if (all(is.na(x))) {
192		# Early return if there are only NAs in input.
193	1x	return(factor(x, ordered = ordered, levels = labels))
194		}
195
196
197	7x	quantiles <- stats::quantile(
198	7x	x,
199	7x	probs = probs,
200	7x	type = type,
201	7x	na.rm = TRUE
202		)
203
204	7x	checkmate::assert_numeric(quantiles, unique = TRUE)
205
206	6x	cut(
207	6x	x,
208	6x	breaks = quantiles,
209	6x	labels = labels,
210	6x	ordered_result = ordered,
211	6x	include.lowest = TRUE,
212	6x	right = TRUE
213		)
214		}
215
216		#' Discard Certain Levels from a Factor
217		#'
218		#' This discards the observations as well as the levels specified from a factor.
219		#'
220		#' @param x (`factor`)\cr the original factor.
221		#' @param discard (`character`)\cr which levels to discard.
222		#'
223		#' @return The modified factor with observations as well as levels from `discard` dropped.
224		#' @export
225		#'
226		#' @examples
227		#' fct_discard(factor(c("a", "b", "c")), "c")
228		fct_discard <- function(x, discard) {
229	247x	checkmate::assert_factor(x)
230	247x	checkmate::assert_character(discard, any.missing = FALSE)
231	247x	new_obs <- x[!(x %in% discard)]
232	247x	new_levels <- setdiff(levels(x), discard)
233	247x	factor(new_obs, levels = new_levels)
234		}
235
236		#' Insertion of Explicit Missings in a Factor
237		#'
238		#' This inserts explicit missings in a factor based on a condition. Note that also additional
239		#' existing `NA` values will be explicitly converted to given `na_level`.
240		#'
241		#' @param x (`factor`)\cr the original factor.
242		#' @param condition (`logical`)\cr where to insert missings.
243		#' @param na_level (`string`)\cr which level to use for missings.
244		#'
245		#' @return The modified factor with inserted and existing `NA` converted to `na_level`.
246		#' @seealso [forcats::fct_na_value_to_level()] which is used internally.
247		#'
248		#' @examples
249		#' fct_explicit_na_if(factor(c("a", "b", NA)), c(TRUE, FALSE, FALSE))
250		#'
251		#' @export
252		fct_explicit_na_if <- function(x, condition, na_level = "<Missing>") {
253	1x	checkmate::assert_factor(x, len = length(condition))
254	1x	checkmate::assert_logical(condition)
255	1x	x[condition] <- NA
256	1x	x <- forcats::fct_na_value_to_level(x, level = na_level)
257	1x	forcats::fct_drop(x, only = na_level)
258		}
259
260		#' Collapsing of Factor Levels and Keeping Only Those New Group Levels
261		#'
262		#' This collapses levels and only keeps those new group levels, in the order provided.
263		#' The returned factor has levels in the order given, with the possible missing level last (this will
264		#' only be included if there are missings). Note that any existing `NA` in the input vector will
265		#' not be replaced by the missing level. If needed [explicit_na()] can be called separately on the result.
266		#'
267		#' @param .f (`factor` or `character`)\cr original vector.
268		#' @param ... (named `character` vectors)\cr levels in each vector provided will be collapsed into
269		#' the new level given by the respective name.
270		#' @param .na_level (`string`)\cr which level to use for other levels, which should be missing in the
271		#' new factor. Note that this level must not be contained in the new levels specified in `...`.
272		#'
273		#' @return The modified factor with collapsed levels. Values and levels which are not included
274		#' in the given character vectors input will be set to the missing level.
275		#' @seealso [forcats::fct_collapse()], [forcats::fct_relevel()] which are used internally.
276		#'
277		#' @examples
278		#' fct_collapse_only(factor(c("a", "b", "c", "d")), TRT = "b", CTRL = c("c", "d"))
279		#'
280		#' @export
281		fct_collapse_only <- function(.f, ..., .na_level = "<Missing>") {
282	4x	new_lvls <- names(list(...))
283	4x	if (checkmate::test_subset(.na_level, new_lvls)) {
284	1x	stop(paste0(".na_level currently set to '", .na_level, "' must not be contained in the new levels"))
285		}
286	3x	x <- forcats::fct_collapse(.f, ..., other_level = .na_level)
287	3x	do.call(forcats::fct_relevel, args = c(list(.f = x), as.list(new_lvls)))
288		}

1		#' Add Titles, Footnotes, Page Number, and a Bounding Box to a Grid Grob
2		#'
3		#' @description `r lifecycle::badge("stable")`
4		#'
5		#' This function is useful to label grid grobs (also \code{ggplot2}, and \code{lattice} plots)
6		#' with title, footnote, and page numbers.
7		#'
8		#' @inheritParams grid::grob
9		#' @param grob a grid grob object, optionally \code{NULL} if only a \code{grob} with
10		#' the decoration should be shown.
11		#' @param titles vector of character strings. Vector elements are separated by a
12		#' newline and strings are wrapped according to the page with.
13		#' @param footnotes vector of character string. Same rules as for \code{titles}.
14		#' @param page string with page numeration, if \code{NULL} then no page number is displayed.
15		#' @param width_titles unit object
16		#' @param width_footnotes unit object
17		#' @param border boolean, whether a a border should be drawn around the plot or
18		#' not.
19		#' @param margins unit object of length 4
20		#' @param padding unit object of length 4
21		#' @param outer_margins unit object of length 4
22		#' @param gp_titles a \code{gpar} object
23		#' @param gp_footnotes a \code{gpar} object
24		#'
25		#' @details
26		#' The titles and footnotes will be ragged, i.e. each title will be wrapped
27		#' individually.
28		#'
29		#' \if{html}{
30		#' The layout can be illustrated as follows:
31		#'
32		#' \figure{decorate_grob.png}{options: alt="decorate_grob layout"}
33		#' }
34		#'
35		#' @return a grid grob (\code{gTree})
36		#'
37		#' @export
38		#' @template author_waddella
39		#'
40		#' @examples
41		#' library(grid)
42		#'
43		#' titles <- c(
44		#' "Edgar Anderson's Iris Data",
45		#' paste(
46		#' "This famous (Fisher's or Anderson's) iris data set gives the measurements",
47		#' "in centimeters of the variables sepal length and width and petal length",
48		#' "and width, respectively, for 50 flowers from each of 3 species of iris."
49		#' )
50		#' )
51		#'
52		#' footnotes <- c(
53		#' "The species are Iris setosa, versicolor, and virginica.",
54		#' paste(
55		#' "iris is a data frame with 150 cases (rows) and 5 variables (columns) named",
56		#' "Sepal.Length, Sepal.Width, Petal.Length, Petal.Width, and Species."
57		#' )
58		#' )
59		#'
60		#' ## empty plot
61		#' grid.newpage()
62		#'
63		#' grid.draw(
64		#' decorate_grob(
65		#' NULL,
66		#' titles = titles,
67		#' footnotes = footnotes,
68		#' page = "Page 4 of 10"
69		#' )
70		#' )
71		#'
72		#' # grid
73		#' p <- gTree(
74		#' children = gList(
75		#' rectGrob(),
76		#' xaxisGrob(),
77		#' yaxisGrob(),
78		#' textGrob("Sepal.Length", y = unit(-4, "lines")),
79		#' textGrob("Petal.Length", x = unit(-3.5, "lines"), rot = 90),
80		#' pointsGrob(iris$Sepal.Length, iris$Petal.Length, gp = gpar(col = iris$Species), pch = 16)
81		#' ),
82		#' vp = vpStack(plotViewport(), dataViewport(xData = iris$Sepal.Length, yData = iris$Petal.Length))
83		#' )
84		#' grid.newpage()
85		#' grid.draw(p)
86		#'
87		#' grid.newpage()
88		#' grid.draw(
89		#' decorate_grob(
90		#' grob = p,
91		#' titles = titles,
92		#' footnotes = footnotes,
93		#' page = "Page 6 of 129"
94		#' )
95		#' )
96		#'
97		#' ## with \code{ggplot2}
98		#' library(ggplot2)
99		#'
100		#' p_gg <- ggplot2::ggplot(iris, aes(Sepal.Length, Sepal.Width, col = Species)) +
101		#' ggplot2::geom_point()
102		#' p_gg
103		#' p <- ggplotGrob(p_gg)
104		#' grid.newpage()
105		#' grid.draw(
106		#' decorate_grob(
107		#' grob = p,
108		#' titles = titles,
109		#' footnotes = footnotes,
110		#' page = "Page 6 of 129"
111		#' )
112		#' )
113		#'
114		#' ## with \code{lattice}
115		#' library(lattice)
116		#'
117		#' xyplot(Sepal.Length ~ Petal.Length, data = iris, col = iris$Species)
118		#' p <- grid.grab()
119		#' grid.newpage()
120		#' grid.draw(
121		#' decorate_grob(
122		#' grob = p,
123		#' titles = titles,
124		#' footnotes = footnotes,
125		#' page = "Page 6 of 129"
126		#' )
127		#' )
128		#'
129		#' # with \code{gridExtra} - no borders
130		#' library(gridExtra)
131		#' grid.newpage()
132		#' grid.draw(
133		#' decorate_grob(
134		#' tableGrob(
135		#' head(mtcars)
136		#' ),
137		#' titles = "title",
138		#' footnotes = "footnote",
139		#' border = FALSE
140		#' )
141		#' )
142		decorate_grob <- function(grob,
143		titles,
144		footnotes,
145		page = "",
146		width_titles = grid::unit(1, "npc"),
147		width_footnotes = grid::unit(1, "npc") - grid::stringWidth(page),
148		border = TRUE,
149		margins = grid::unit(c(1, 0, 1, 0), "lines"),
150		padding = grid::unit(rep(1, 4), "lines"),
151		outer_margins = grid::unit(c(2, 1.5, 3, 1.5), "cm"),
152		gp_titles = grid::gpar(),
153		gp_footnotes = grid::gpar(fontsize = 8),
154		name = NULL,
155		gp = grid::gpar(),
156		vp = NULL) {
157	8x	st_titles <- split_text_grob(
158	8x	titles,
159	8x	x = 0, y = 1,
160	8x	just = c("left", "top"),
161	8x	width = width_titles,
162	8x	vp = grid::viewport(layout.pos.row = 1, layout.pos.col = 1),
163	8x	gp = gp_titles
164		)
165
166	8x	st_footnotes <- split_text_grob(
167	8x	footnotes,
168	8x	x = 0, y = 1,
169	8x	just = c("left", "top"),
170	8x	width = width_footnotes,
171	8x	vp = grid::viewport(layout.pos.row = 3, layout.pos.col = 1),
172	8x	gp = gp_footnotes
173		)
174
175	8x	grid::gTree(
176	8x	grob = grob,
177	8x	titles = titles,
178	8x	footnotes = footnotes,
179	8x	page = page,
180	8x	width_titles = width_titles,
181	8x	width_footnotes = width_footnotes,
182	8x	border = border,
183	8x	margins = margins,
184	8x	padding = padding,
185	8x	outer_margins = outer_margins,
186	8x	gp_titles = gp_titles,
187	8x	gp_footnotes = gp_footnotes,
188	8x	children = grid::gList(
189	8x	grid::gTree(
190	8x	children = grid::gList(
191	8x	st_titles,
192	8x	grid::gTree(
193	8x	children = grid::gList(
194	8x	if (border) grid::rectGrob(),
195	8x	grid::gTree(
196	8x	children = grid::gList(
197	8x	grob
198		),
199	8x	vp = grid::plotViewport(margins = padding)
200		)
201		),
202	8x	vp = grid::vpStack(
203	8x	grid::viewport(layout.pos.row = 2, layout.pos.col = 1),
204	8x	grid::plotViewport(margins = margins)
205		)
206		),
207	8x	st_footnotes,
208	8x	grid::textGrob(
209	8x	page,
210	8x	x = 1, y = 0,
211	8x	just = c("right", "bottom"),
212	8x	vp = grid::viewport(layout.pos.row = 3, layout.pos.col = 1),
213	8x	gp = gp_footnotes
214		)
215		),
216	8x	childrenvp = NULL,
217	8x	name = "titles_grob_footnotes",
218	8x	vp = grid::vpStack(
219	8x	grid::plotViewport(margins = outer_margins),
220	8x	grid::viewport(
221	8x	layout = grid::grid.layout(
222	8x	nrow = 3, ncol = 1,
223	8x	heights = grid::unit.c(
224	8x	grid::grobHeight(st_titles),
225	8x	grid::unit(1, "null"),
226	8x	grid::grobHeight(st_footnotes)
227		)
228		)
229		)
230		)
231		)
232		),
233	8x	name = name,
234	8x	gp = gp,
235	8x	vp = vp,
236	8x	cl = "decoratedGrob"
237		)
238		}
239
240		#' @importFrom grid validDetails
241		#' @export
242		validDetails.decoratedGrob <- function(x) { # nolint
243
244	8x	checkmate::assert_character(x$titles)
245	8x	checkmate::assert_character(x$footnotes)
246
247	8x	if (!is.null(x$grob)) {
248	7x	checkmate::assert_true(grid::is.grob(x$grob))
249		}
250	8x	if (length(x$page) == 1) {
251	8x	checkmate::assert_character(x$page)
252		}
253	8x	if (!grid::is.unit(x$outer_margins)) {
254	1x	checkmate::assert_vector(x$outer_margins, len = 4)
255		}
256	8x	if (!grid::is.unit(x$margins)) {
257	1x	checkmate::assert_vector(x$margins, len = 4)
258		}
259	8x	if (!grid::is.unit(x$padding)) {
260	1x	checkmate::assert_vector(x$padding, len = 4)
261		}
262
263	8x	x
264		}
265
266		#' @importFrom grid widthDetails
267		#' @export
268		widthDetails.decoratedGrob <- function(x) { # nolint
269	!	grid::unit(1, "null")
270		}
271
272		#' @importFrom grid heightDetails
273		#' @export
274		heightDetails.decoratedGrob <- function(x) { # nolint
275	!	grid::unit(1, "null")
276		}
277
278		# Adapted from Paul Murell R Graphics 2nd Edition
279		# https://www.stat.auckland.ac.nz/~paul/RG2e/interactgrid-splittext.R
280		split_string <- function(text, width) {
281	19x	availwidth <- grid::convertWidth(width, "in", valueOnly = TRUE)
282	19x	textwidth <- grid::convertWidth(grid::stringWidth(text), "in", valueOnly = TRUE)
283	19x	strings <- strsplit(text, " ")[[1]]
284
285	19x	if (textwidth <= availwidth \|\| length(strings) == 1) {
286	18x	text
287		} else {
288	1x	gapwidth <- grid::stringWidth(" ")
289	1x	newstring <- strings[1]
290	1x	linewidth <- grid::stringWidth(newstring)
291
292	1x	for (i in 2:length(strings)) {
293	7x	str_width <- grid::stringWidth(strings[i])
294	7x	if (grid::convertWidth(linewidth + gapwidth + str_width, "in", valueOnly = TRUE) < availwidth) {
295	5x	sep <- " "
296	5x	linewidth <- linewidth + gapwidth + str_width
297		} else {
298	2x	sep <- "\n"
299	2x	linewidth <- str_width
300		}
301	7x	newstring <- paste(newstring, strings[i], sep = sep)
302		}
303	1x	newstring
304		}
305		}
306
307		#' Split Text According To Available Text Width
308		#'
309		#' Dynamically wrap text.
310		#'
311		#' @inheritParams grid::grid.text
312		#' @param text character string
313		#' @param width a unit object specifying max width of text
314		#'
315		#' @details
316		#' This code is taken from R Graphics by \code{Paul Murell}, 2nd edition
317		#'
318		#' @examples
319		#' # Internal function - split_text_grob
320		#' \dontrun{
321		#' sg <- split_text_grob(text = paste(
322		#' "Lorem ipsum dolor sit amet, consectetur adipiscing elit. Vestibulum vitae",
323		#' "dapibus dolor, ac mattis erat. Nunc metus lectus, imperdiet ut enim eu,",
324		#' "commodo scelerisque urna. Vestibulum facilisis metus vel nibh tempor, sed",
325		#' "elementum sem tempus. Morbi quis arcu condimentum, maximus lorem id,",
326		#' "tristique ante. Nullam a nunc dui. Fusce quis lacus nec ante dignissim",
327		#' "faucibus nec vitae tellus. Suspendisse mollis et sapien eu ornare. Vestibulum",
328		#' "placerat neque nec justo efficitur, ornare varius nulla imperdiet. Nunc justo",
329		#' "sapien, vestibulum eget efficitur eget, porttitor id ante. Nulla tempor",
330		#' "luctus massa id elementum. Praesent dictum, neque vitae vestibulum malesuada,",
331		#' "nunc nisi blandit lacus, sit amet tristique odio dui sit amet velit."
332		#' ))
333		#'
334		#' library(grid)
335		#' grobHeight(sg)
336		#'
337		#' grid.newpage()
338		#' pushViewport(plotViewport())
339		#' grid.rect()
340		#' grid.draw(sg)
341		#'
342		#' grid.rect(
343		#' height = grobHeight(sg), width = unit(1, "cm"), gp = gpar(fill = "red")
344		#' )
345		#'
346		#' # stack split_text_grob
347		#' grid.newpage()
348		#' pushViewport(plotViewport())
349		#' grid.rect()
350		#' grid.draw(split_text_grob(
351		#' c("Hello, this is a test", "and yet another test"),
352		#' just = c("left", "top"), x = 0, y = 1
353		#' ))
354		#' }
355		#'
356		#' @keywords internal
357		split_text_grob <- function(text,
358		x = grid::unit(0.5, "npc"),
359		y = grid::unit(0.5, "npc"),
360		width = grid::unit(1, "npc"),
361		just = "centre",
362		hjust = NULL,
363		vjust = NULL,
364		default.units = "npc", # nolint
365		name = NULL,
366		gp = grid::gpar(),
367		vp = NULL) {
368	16x	if (!grid::is.unit(x)) {
369	16x	x <- grid::unit(x, default.units)
370		}
371	16x	if (!grid::is.unit(y)) {
372	16x	y <- grid::unit(y, default.units)
373		}
374
375	16x	checkmate::assert_true(grid::is.unit(width))
376	16x	checkmate::assert_vector(width, len = 1)
377
378		## if it is a fixed unit then we do not need to recalculate when viewport resized
379	16x	if (!inherits(width, "unit.arithmetic") &&
380	16x	!is.null(attr(width, "unit")) &&
381	16x	attr(width, "unit") %in% c("cm", "inches", "mm", "points", "picas", "bigpts", "dida", "cicero", "scaledpts")) {
382	!	attr(text, "fixed_text") <- paste(vapply(text, split_string, character(1), width = width), collapse = "\n")
383		}
384
385	16x	grid::grob(
386	16x	text = text,
387	16x	x = x, y = y,
388	16x	width = width,
389	16x	just = just,
390	16x	hjust = hjust,
391	16x	vjust = vjust,
392	16x	rot = 0,
393	16x	check.overlap = FALSE,
394	16x	name = name,
395	16x	gp = gp,
396	16x	vp = vp,
397	16x	cl = "dynamicSplitText"
398		)
399		}
400
401		#' @importFrom grid validDetails
402		#' @export
403		validDetails.dynamicSplitText <- function(x) { # nolint
404	16x	checkmate::assert_character(x$text)
405	16x	checkmate::assert_true(grid::is.unit(x$width))
406	16x	checkmate::assert_vector(x$width, len = 1)
407	16x	x
408		}
409
410		#' @importFrom grid heightDetails
411		#' @export
412		heightDetails.dynamicSplitText <- function(x) { # nolint
413	12x	txt <- if (!is.null(attr(x$text, "fixed_text"))) {
414	!	attr(x$text, "fixed_text")
415		} else {
416	12x	paste(vapply(x$text, split_string, character(1), width = x$width), collapse = "\n")
417		}
418	12x	grid::stringHeight(txt)
419		}
420
421		#' @importFrom grid widthDetails
422		#' @export
423		widthDetails.dynamicSplitText <- function(x) { # nolint
424	!	x$width
425		}
426
427		#' @importFrom grid drawDetails
428		#' @export
429		drawDetails.dynamicSplitText <- function(x, recording) { # nolint
430	6x	txt <- if (!is.null(attr(x$text, "fixed_text"))) {
431	!	attr(x$text, "fixed_text")
432		} else {
433	6x	paste(vapply(x$text, split_string, character(1), width = x$width), collapse = "\n")
434		}
435
436	6x	x$width <- NULL
437	6x	x$label <- txt
438	6x	x$text <- NULL
439	6x	class(x) <- c("text", class(x)[-1])
440
441	6x	grid::grid.draw(x)
442		}
443
444		#' Update Page Number
445		#'
446		#' Automatically updates page number.
447		#'
448		#' @param npages number of pages in total
449		#' @param ... passed on to \code{\link{decorate_grob}}
450		#'
451		#' @return closure that increments the page number
452		#'
453		#' @keywords internal
454		#' @template author_waddella
455		#'
456		#' @examples
457		#' # Internal function - decorate_grob_factory
458		#' \dontrun{
459		#' pf <- decorate_grob_factory(
460		#' titles = "This is a test\nHello World",
461		#' footnotes = "Here belong the footnotess",
462		#' npages = 3
463		#' )
464		#'
465		#' library(grid)
466		#' draw_grob(pf(NULL))
467		#' draw_grob(pf(NULL))
468		#' draw_grob(pf(NULL))
469		#' }
470		decorate_grob_factory <- function(npages, ...) {
471	2x	current_page <- 0
472	2x	function(grob) {
473	7x	current_page <<- current_page + 1
474	7x	if (current_page > npages) {
475	1x	stop(paste("current page is", current_page, "but max.", npages, "specified."))
476		}
477	6x	decorate_grob(grob = grob, page = paste("Page", current_page, "of", npages), ...)
478		}
479		}
480
481		#' Decorate Set of `grobs` and Add Page Numbering
482		#'
483		#' @description `r lifecycle::badge("stable")`
484		#'
485		#' Note that this uses the `decorate_grob_factory` function.
486		#'
487		#' @param grobs a list of grid grobs
488		#' @param ... arguments passed on to \code{\link{decorate_grob}}
489		#'
490		#' @template author_waddella
491		#'
492		#' @examples
493		#' library(ggplot2)
494		#' library(grid)
495		#' g <- with(data = iris, {
496		#' list(
497		#' ggplot2::ggplotGrob(
498		#' ggplot2::ggplot(mapping = aes(Sepal.Length, Sepal.Width, col = Species)) +
499		#' ggplot2::geom_point()
500		#' ),
501		#' ggplot2::ggplotGrob(
502		#' ggplot2::ggplot(mapping = aes(Sepal.Length, Petal.Length, col = Species)) +
503		#' ggplot2::geom_point()
504		#' ),
505		#' ggplot2::ggplotGrob(
506		#' ggplot2::ggplot(mapping = aes(Sepal.Length, Petal.Width, col = Species)) +
507		#' ggplot2::geom_point()
508		#' ),
509		#' ggplot2::ggplotGrob(
510		#' ggplot2::ggplot(mapping = aes(Sepal.Width, Petal.Length, col = Species)) +
511		#' ggplot2::geom_point()
512		#' ),
513		#' ggplot2::ggplotGrob(
514		#' ggplot2::ggplot(mapping = aes(Sepal.Width, Petal.Width, col = Species)) +
515		#' ggplot2::geom_point()
516		#' ),
517		#' ggplot2::ggplotGrob(
518		#' ggplot2::ggplot(mapping = aes(Petal.Length, Petal.Width, col = Species)) +
519		#' ggplot2::geom_point()
520		#' )
521		#' )
522		#' })
523		#' lg <- decorate_grob_set(grobs = g, titles = "Hello\nOne\nTwo\nThree", footnotes = "")
524		#'
525		#' draw_grob(lg[[1]])
526		#' draw_grob(lg[[2]])
527		#' draw_grob(lg[[6]])
528		#'
529		#' @export
530		decorate_grob_set <- function(grobs, ...) {
531	1x	n <- length(grobs)
532	1x	lgf <- decorate_grob_factory(npages = n, ...)
533	1x	lapply(grobs, lgf)
534		}

1		#' Patient Counts with the Most Extreme Post-baseline Toxicity Grade per Direction of Abnormality
2		#'
3		#' @description `r lifecycle::badge("stable")`
4		#'
5		#' Primary analysis variable `.var` indicates the toxicity grade (factor), and additional
6		#' analysis variables are `id` (character or factor), `param` (`factor`) and `grade_dir` (`factor`).
7		#' The pre-processing steps are crucial when using this function.
8		#' For a certain direction (e.g. high or low) this function counts
9		#' patients in the denominator as number of patients with at least one valid measurement during treatment,
10		#' and patients in the numerator as follows:
11		#' * `1` to `4`: Numerator is number of patients with worst grades 1-4 respectively;
12		#' * `Any`: Numerator is number of patients with at least one abnormality, which means grade is different from 0.
13		#'
14		#' @details
15		#' The pre-processing steps are crucial when using this function. From the standard
16		#' lab grade variable `ATOXGR`, derive the following two variables:
17		#' * A grade direction variable (e.g. `GRADE_DIR`) is required in order to obtain
18		#' the correct denominators when building the layout as it is used to define row splitting.
19		#' * A toxicity grade variable (e.g. `GRADE_ANL`) where all negative values from
20		#' `ATOXGR` are replaced by their absolute values.
21		#' * Prior to tabulation, `df` must filtered to include only post-baseline records with worst grade flags.
22		#'
23		#' @inheritParams argument_convention
24		#'
25		#' @name abnormal_by_worst_grade
26		NULL
27
28		#' @describeIn abnormal_by_worst_grade Statistics function which counts patients with worst grade,
29		#' consisting of counts and percentages of patients with worst grade
30		#' `1` to `4`, and `Any` non-zero grade.
31		#'
32		#' @return [s_count_abnormal_by_worst_grade()] the single statistic `count_fraction` with grade 1 to 4
33		#' and "Any" results.
34		#'
35		#' @examples
36		#' library(dplyr)
37		#' library(forcats)
38		#' adlb <- tern_ex_adlb
39		#'
40		#' # Data is modified in order to have some parameters with grades only in one direction
41		#' # and simulate the real data.
42		#' adlb$ATOXGR[adlb$PARAMCD == "ALT" & adlb$ATOXGR %in% c("1", "2", "3", "4")] <- "-1"
43		#' adlb$ANRIND[adlb$PARAMCD == "ALT" & adlb$ANRIND == "HIGH"] <- "LOW"
44		#' adlb$WGRHIFL[adlb$PARAMCD == "ALT"] <- ""
45		#'
46		#' adlb$ATOXGR[adlb$PARAMCD == "IGA" & adlb$ATOXGR %in% c("-1", "-2", "-3", "-4")] <- "1"
47		#' adlb$ANRIND[adlb$PARAMCD == "IGA" & adlb$ANRIND == "LOW"] <- "HIGH"
48		#' adlb$WGRLOFL[adlb$PARAMCD == "IGA"] <- ""
49		#'
50		#' # Here starts the real pre-processing.
51		#' adlb_f <- adlb %>%
52		#' filter(!AVISIT %in% c("SCREENING", "BASELINE")) %>%
53		#' mutate(
54		#' GRADE_DIR = factor(
55		#' case_when(
56		#' ATOXGR %in% c("-1", "-2", "-3", "-4") ~ "LOW",
57		#' ATOXGR == "0" ~ "ZERO",
58		#' ATOXGR %in% c("1", "2", "3", "4") ~ "HIGH"
59		#' ),
60		#' levels = c("LOW", "ZERO", "HIGH")
61		#' ),
62		#' GRADE_ANL = fct_relevel(
63		#' fct_recode(ATOXGR, `1` = "-1", `2` = "-2", `3` = "-3", `4` = "-4"),
64		#' c("0", "1", "2", "3", "4")
65		#' )
66		#' ) %>%
67		#' filter(WGRLOFL == "Y" \| WGRHIFL == "Y") %>%
68		#' droplevels()
69		#'
70		#' adlb_f_alt <- adlb_f %>%
71		#' filter(PARAMCD == "ALT") %>%
72		#' droplevels()
73		#' full_parent_df <- list(adlb_f_alt, "not_needed")
74		#' cur_col_subset <- list(rep(TRUE, nrow(adlb_f_alt)), "not_needed")
75		#'
76		#' # This mimics a split structure on PARAM and GRADE_DIR for a total column
77		#' spl_context <- data.frame(
78		#' split = c("PARAM", "GRADE_DIR"),
79		#' full_parent_df = I(full_parent_df),
80		#' cur_col_subset = I(cur_col_subset)
81		#' )
82		#'
83		#' # Internal function - s_count_abnormal_by_worst_grade
84		#' \dontrun{
85		#' s_count_abnormal_by_worst_grade(
86		#' df = adlb_f_alt,
87		#' .spl_context = spl_context,
88		#' .var = "GRADE_ANL"
89		#' )
90		#' }
91		#'
92		#' @keywords internal
93		s_count_abnormal_by_worst_grade <- function(df, # nolint
94		.var = "GRADE_ANL",
95		.spl_context,
96		variables = list(
97		id = "USUBJID",
98		param = "PARAM",
99		grade_dir = "GRADE_DIR"
100		)) {
101	1x	checkmate::assert_string(.var)
102	1x	assert_valid_factor(df[[.var]])
103	1x	assert_valid_factor(df[[variables$param]])
104	1x	assert_valid_factor(df[[variables$grade_dir]])
105	1x	assert_df_with_variables(df, c(a = .var, variables))
106	1x	checkmate::assert_multi_class(df[[variables$id]], classes = c("factor", "character"))
107
108		# To verify that the `split_rows_by` are performed with correct variables.
109	1x	checkmate::assert_subset(c(variables[["param"]], variables[["grade_dir"]]), .spl_context$split)
110	1x	first_row <- .spl_context[.spl_context$split == variables[["param"]], ] # nolint
111	1x	x_lvls <- c(setdiff(levels(df[[.var]]), "0"), "Any")
112	1x	result <- split(numeric(0), factor(x_lvls))
113
114	1x	subj <- first_row$full_parent_df[[1]][[variables[["id"]]]]
115	1x	subj_cur_col <- subj[first_row$cur_col_subset[[1]]]
116		# Some subjects may have a record for high and low directions but
117		# should be counted only once.
118	1x	denom <- length(unique(subj_cur_col))
119
120	1x	for (lvl in x_lvls) {
121	5x	if (lvl != "Any") {
122	4x	df_lvl <- df[df[[.var]] == lvl, ]
123		} else {
124	1x	df_lvl <- df[df[[.var]] != 0, ]
125		}
126	5x	num <- length(unique(df_lvl[["USUBJID"]]))
127	5x	fraction <- ifelse(denom == 0, 0, num / denom)
128	5x	result[[lvl]] <- formatters::with_label(c(count = num, fraction = fraction), lvl)
129		}
130
131	1x	result <- list(count_fraction = result)
132	1x	result
133		}
134
135		#' @describeIn abnormal_by_worst_grade Formatted Analysis function which can be further customized by calling
136		#' [rtables::make_afun()] on it. It is used as `afun` in [rtables::analyze()].
137		#'
138		#' @return [a_count_abnormal_by_worst_grade()] returns the corresponding list with formatted [rtables::CellValue()].
139		#'
140		#' @examples
141		#' # Internal function - a_count_abnormal_by_worst_grade
142		#' \dontrun{
143		#' # Use the Formatted Analysis function for `analyze()`. We need to ungroup `count_fraction` first
144		#' # so that the `rtables` formatting function `format_count_fraction()` can be applied correctly.
145		#' afun <- make_afun(a_count_abnormal_by_worst_grade, .ungroup_stats = "count_fraction")
146		#' afun(df = adlb_f_alt, .spl_context = spl_context)
147		#' }
148		#'
149		#' @keywords internal
150		a_count_abnormal_by_worst_grade <- make_afun( # nolint
151		s_count_abnormal_by_worst_grade,
152		.formats = c(count_fraction = format_count_fraction)
153		)
154
155		#' @describeIn abnormal_by_worst_grade Layout creating function which can be used for creating tables,
156		#' which can take statistics function arguments and additional format arguments (see below).
157		#'
158		#' @examples
159		#' # Map excludes records without abnormal grade since they should not be displayed
160		#' # in the table.
161		#' map <- unique(adlb_f[adlb_f$GRADE_DIR != "ZERO", c("PARAM", "GRADE_DIR", "GRADE_ANL")]) %>%
162		#' lapply(as.character) %>%
163		#' as.data.frame() %>%
164		#' arrange(PARAM, desc(GRADE_DIR), GRADE_ANL)
165		#'
166		#' basic_table() %>%
167		#' split_cols_by("ARMCD") %>%
168		#' split_rows_by("PARAM") %>%
169		#' split_rows_by("GRADE_DIR", split_fun = trim_levels_to_map(map)) %>%
170		#' count_abnormal_by_worst_grade(
171		#' var = "GRADE_ANL",
172		#' variables = list(id = "USUBJID", param = "PARAM", grade_dir = "GRADE_DIR")
173		#' ) %>%
174		#' build_table(df = adlb_f)
175		#'
176		#' @export
177		count_abnormal_by_worst_grade <- function(lyt,
178		var,
179		...,
180		.stats = NULL,
181		.formats = NULL,
182		.labels = NULL,
183		.indent_mods = NULL) {
184	2x	afun <- make_afun(
185	2x	a_count_abnormal_by_worst_grade,
186	2x	.stats = .stats,
187	2x	.formats = .formats,
188	2x	.labels = .labels,
189	2x	.indent_mods = .indent_mods,
190	2x	.ungroup_stats = "count_fraction"
191		)
192	2x	analyze(
193	2x	lyt = lyt,
194	2x	vars = var,
195	2x	afun = afun,
196	2x	extra_args = list(...),
197	2x	show_labels = "hidden"
198		)
199		}

1		#' Odds Ratio Estimation
2		#'
3		#' @description `r lifecycle::badge("stable")`
4		#'
5		#' Compares bivariate responses between two groups in terms of odds ratios
6		#' along with a confidence interval.
7		#'
8		#' @details This function uses either logistic regression for unstratified
9		#' analyses, or conditional logistic regression for stratified analyses.
10		#' The Wald confidence interval with the specified confidence level is
11		#' calculated. Note that, for stratified analyses, there is currently no
12		#' implementation for conditional likelihood confidence intervals,
13		#' therefore the likelihood confidence interval as an option is not yet
14		#' available. Besides, when `rsp` contains only responders or non-responders,
15		#' then the result values will be `NA`, because no odds ratio estimation is
16		#' possible.
17		#' @seealso Relevant helper function [h_odds_ratio()].
18		#'
19		#' @name odds_ratio
20		NULL
21
22		#' @describeIn odds_ratio Statistics function which estimates the odds ratio
23		#' between a treatment and a control. Note that a `variables` list with `arm` and `strata` names
24		#' needs to be passed if a stratified analysis is required.
25		#' @inheritParams split_cols_by_groups
26		#' @inheritParams argument_convention
27		#' @export
28		#'
29		#' @examples
30		#' set.seed(12)
31		#' dta <- data.frame(
32		#' rsp = sample(c(TRUE, FALSE), 100, TRUE),
33		#' grp = factor(rep(c("A", "B"), each = 50), levels = c("B", "A")),
34		#' strata = factor(sample(c("C", "D"), 100, TRUE))
35		#' )
36		#'
37		#' # Unstratified analysis.
38		#' s_odds_ratio(
39		#' df = subset(dta, grp == "A"),
40		#' .var = "rsp",
41		#' .ref_group = subset(dta, grp == "B"),
42		#' .in_ref_col = FALSE,
43		#' .df_row = dta
44		#' )
45		#'
46		#' # Stratified analysis.
47		#' s_odds_ratio(
48		#' df = subset(dta, grp == "A"),
49		#' .var = "rsp",
50		#' .ref_group = subset(dta, grp == "B"),
51		#' .in_ref_col = FALSE,
52		#' .df_row = dta,
53		#' variables = list(arm = "grp", strata = "strata")
54		#' )
55		s_odds_ratio <- function(df,
56		.var,
57		.ref_group,
58		.in_ref_col,
59		.df_row,
60		variables = list(arm = NULL, strata = NULL),
61		conf_level = 0.95,
62		groups_list = NULL) {
63	65x	y <- list(or_ci = "", n_tot = "")
64
65	65x	if (!.in_ref_col) {
66	65x	assert_proportion_value(conf_level)
67	65x	assert_df_with_variables(df, list(rsp = .var))
68	65x	assert_df_with_variables(.ref_group, list(rsp = .var))
69
70	65x	if (is.null(variables$strata)) {
71	52x	data <- data.frame(
72	52x	rsp = c(.ref_group[[.var]], df[[.var]]),
73	52x	grp = factor(
74	52x	rep(c("ref", "Not-ref"), c(nrow(.ref_group), nrow(df))),
75	52x	levels = c("ref", "Not-ref")
76		)
77		)
78	52x	y <- or_glm(data, conf_level = conf_level)
79		} else {
80	13x	assert_df_with_variables(.df_row, c(list(rsp = .var), variables))
81
82		# The group variable prepared for clogit must be synchronised with combination groups definition.
83	13x	if (is.null(groups_list)) {
84	12x	ref_grp <- as.character(unique(.ref_group[[variables$arm]]))
85	12x	trt_grp <- as.character(unique(df[[variables$arm]]))
86	12x	grp <- stats::relevel(factor(.df_row[[variables$arm]]), ref = ref_grp)
87		} else {
88		# If more than one level in reference col.
89	1x	reference <- as.character(unique(.ref_group[[variables$arm]]))
90	1x	grp_ref_flag <- vapply(
91	1x	X = groups_list,
92	1x	FUN.VALUE = TRUE,
93	1x	FUN = function(x) all(reference %in% x)
94		)
95	1x	ref_grp <- names(groups_list)[grp_ref_flag]
96
97		# If more than one level in treatment col.
98	1x	treatment <- as.character(unique(df[[variables$arm]]))
99	1x	grp_trt_flag <- vapply(
100	1x	X = groups_list,
101	1x	FUN.VALUE = TRUE,
102	1x	FUN = function(x) all(treatment %in% x)
103		)
104	1x	trt_grp <- names(groups_list)[grp_trt_flag]
105
106	1x	grp <- combine_levels(.df_row[[variables$arm]], levels = reference, new_level = ref_grp)
107	1x	grp <- combine_levels(grp, levels = treatment, new_level = trt_grp)
108		}
109
110		# The reference level in `grp` must be the same as in the `rtables` column split.
111	13x	data <- data.frame(
112	13x	rsp = .df_row[[.var]],
113	13x	grp = grp,
114	13x	strata = interaction(.df_row[variables$strata])
115		)
116	13x	y_all <- or_clogit(data, conf_level = conf_level)
117	13x	checkmate::assert_string(trt_grp)
118	13x	checkmate::assert_subset(trt_grp, names(y_all$or_ci))
119	12x	y$or_ci <- y_all$or_ci[[trt_grp]]
120	12x	y$n_tot <- y_all$n_tot
121		}
122		}
123
124	64x	y$or_ci <- formatters::with_label(
125	64x	x = y$or_ci,
126	64x	label = paste0("Odds Ratio (", 100 * conf_level, "% CI)")
127		)
128
129	64x	y$n_tot <- formatters::with_label(
130	64x	x = y$n_tot,
131	64x	label = "Total n"
132		)
133
134	64x	y
135		}
136
137		#' @describeIn odds_ratio Formatted Analysis function which can be further customized by calling
138		#' [rtables::make_afun()] on it. It is used as `afun` in [rtables::analyze()].
139		#' @export
140		#'
141		#' @examples
142		#' a_odds_ratio(
143		#' df = subset(dta, grp == "A"),
144		#' .var = "rsp",
145		#' .ref_group = subset(dta, grp == "B"),
146		#' .in_ref_col = FALSE,
147		#' .df_row = dta
148		#' )
149		a_odds_ratio <- make_afun(
150		s_odds_ratio,
151		.formats = c(or_ci = "xx.xx (xx.xx - xx.xx)"),
152		.indent_mods = c(or_ci = 1L)
153		)
154
155		#' @describeIn odds_ratio Layout creating function which can be used for creating
156		#' tables, which can take statistics function arguments and additional format
157		#' arguments (see below).
158		#'
159		#' @inheritParams argument_convention
160		#' @param ... arguments passed to `s_odds_ratio()`.
161		#' @export
162		#'
163		#' @examples
164		#' dta <- data.frame(
165		#' rsp = sample(c(TRUE, FALSE), 100, TRUE),
166		#' grp = factor(rep(c("A", "B"), each = 50))
167		#' )
168		#'
169		#' l <- basic_table() %>%
170		#' split_cols_by(var = "grp", ref_group = "B") %>%
171		#' estimate_odds_ratio(vars = "rsp")
172		#'
173		#' build_table(l, df = dta)
174		estimate_odds_ratio <- function(lyt,
175		vars,
176		...,
177		show_labels = "hidden",
178		table_names = vars,
179		.stats = "or_ci",
180		.formats = NULL,
181		.labels = NULL,
182		.indent_mods = NULL) {
183	3x	afun <- make_afun(
184	3x	a_odds_ratio,
185	3x	.stats = .stats,
186	3x	.formats = .formats,
187	3x	.labels = .labels,
188	3x	.indent_mods = .indent_mods
189		)
190
191	3x	analyze(
192	3x	lyt,
193	3x	vars,
194	3x	afun = afun,
195	3x	extra_args = list(...),
196	3x	show_labels = show_labels,
197	3x	table_names = table_names
198		)
199		}
200
201		#' Helper Functions for Odds Ratio Estimation
202		#'
203		#' @description `r lifecycle::badge("stable")`
204		#'
205		#' Functions to calculate odds ratios in [estimate_odds_ratio()].
206		#'
207		#' @inheritParams argument_convention
208		#' @param data (`data.frame`)\cr data frame containing at least the variables `rsp` and `grp`, and optionally
209		#' `strata` for [or_clogit()].
210		#'
211		#' @seealso [odds_ratio]
212		#'
213		#' @name h_odds_ratio
214		NULL
215
216		#' @describeIn h_odds_ratio estimates the odds ratio based on [stats::glm()]. Note that there must be
217		#' exactly 2 groups in `data` as specified by the `grp` variable.
218		#'
219		#' @export
220		#'
221		#' @examples
222		#' # Data with 2 groups.
223		#' data <- data.frame(
224		#' rsp = as.logical(c(1, 1, 0, 1, 0, 0, 1, 1)),
225		#' grp = letters[c(1, 1, 1, 2, 2, 2, 1, 2)],
226		#' strata = letters[c(1, 2, 1, 2, 2, 2, 1, 2)],
227		#' stringsAsFactors = TRUE
228		#' )
229		#'
230		#' # Odds ratio based on glm.
231		#' or_glm(data, conf_level = 0.95)
232		or_glm <- function(data, conf_level) {
233	55x	checkmate::assert_logical(data$rsp)
234	55x	assert_proportion_value(conf_level)
235	55x	assert_df_with_variables(data, list(rsp = "rsp", grp = "grp"))
236	55x	checkmate::assert_multi_class(data$grp, classes = c("factor", "character"))
237
238	55x	data$grp <- as_factor_keep_attributes(data$grp)
239	55x	assert_df_with_factors(data, list(val = "grp"), min.levels = 2, max.levels = 2)
240	55x	formula <- stats::as.formula("rsp ~ grp")
241	55x	model_fit <- stats::glm(
242	55x	formula = formula, data = data,
243	55x	family = stats::binomial(link = "logit")
244		)
245
246		# Note that here we need to discard the intercept.
247	55x	or <- exp(stats::coef(model_fit)[-1])
248	55x	or_ci <- exp(
249	55x	stats::confint.default(model_fit, level = conf_level)[-1, , drop = FALSE]
250		)
251
252	55x	values <- stats::setNames(c(or, or_ci), c("est", "lcl", "ucl"))
253	55x	n_tot <- stats::setNames(nrow(model_fit$model), "n_tot")
254
255	55x	list(or_ci = values, n_tot = n_tot)
256		}
257
258		#' @describeIn h_odds_ratio estimates the odds ratio based on [survival::clogit()]. This is done for
259		#' the whole data set including all groups, since the results are not the same as when doing
260		#' pairwise comparisons between the groups.
261		#'
262		#' @export
263		#'
264		#' @examples
265		#' # Data with 3 groups.
266		#' data <- data.frame(
267		#' rsp = as.logical(c(1, 1, 0, 1, 0, 0, 1, 1, 0, 0, 1, 1, 0, 1, 0, 0, 1, 1, 0, 0)),
268		#' grp = letters[c(1, 1, 1, 2, 2, 2, 3, 3, 3, 3, 1, 1, 1, 2, 2, 2, 3, 3, 3, 3)],
269		#' strata = LETTERS[c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2)],
270		#' stringsAsFactors = TRUE
271		#' )
272		#'
273		#' # Odds ratio based on stratified estimation by conditional logistic regression.
274		#' or_clogit(data, conf_level = 0.95)
275		or_clogit <- function(data, conf_level) {
276	16x	checkmate::assert_logical(data$rsp)
277	16x	assert_proportion_value(conf_level)
278	16x	assert_df_with_variables(data, list(rsp = "rsp", grp = "grp", strata = "strata"))
279	16x	checkmate::assert_multi_class(data$grp, classes = c("factor", "character"))
280	16x	checkmate::assert_multi_class(data$strata, classes = c("factor", "character"))
281
282	16x	data$grp <- as_factor_keep_attributes(data$grp)
283	16x	data$strata <- as_factor_keep_attributes(data$strata)
284
285		# Deviation from convention: `survival::strata` must be simply `strata`.
286	16x	formula <- stats::as.formula("rsp ~ grp + strata(strata)")
287	16x	model_fit <- clogit_with_tryCatch(formula = formula, data = data)
288
289		# Create a list with one set of OR estimates and CI per coefficient, i.e.
290		# comparison of one group vs. the reference group.
291	16x	coef_est <- stats::coef(model_fit)
292	16x	ci_est <- stats::confint(model_fit, level = conf_level)
293	16x	or_ci <- list()
294	16x	for (coef_name in names(coef_est)) {
295	18x	grp_name <- gsub("^grp", "", x = coef_name)
296	18x	or_ci[[grp_name]] <- stats::setNames(
297	18x	object = exp(c(coef_est[coef_name], ci_est[coef_name, , drop = TRUE])),
298	18x	nm = c("est", "lcl", "ucl")
299		)
300		}
301	16x	list(or_ci = or_ci, n_tot = c(n_tot = model_fit$n))
302		}

1		#' Tabulate Binary Response by Subgroup
2		#'
3		#' @description `r lifecycle::badge("stable")`
4		#'
5		#' Tabulate statistics such as response rate and odds ratio for population subgroups.
6		#'
7		#' @details These functions create a layout starting from a data frame which contains
8		#' the required statistics. Tables typically used as part of forest plot.
9		#'
10		#' @inheritParams argument_convention
11		#' @param data (`data.frame`)\cr the dataset containing the variables to summarize.
12		#' @param groups_lists (named `list` of `list`)\cr optionally contains for each `subgroups` variable a
13		#' list, which specifies the new group levels via the names and the
14		#' levels that belong to it in the character vectors that are elements of the list.
15		#' @param label_all (`string`)\cr label for the total population analysis.
16		#' @param method (`string`)\cr specifies the test used to calculate the p-value for the difference between
17		#' two proportions. For options, see [s_test_proportion_diff()]. Default is `NULL` so no test is performed.
18		#' @name response_subgroups
19		#' @seealso [extract_rsp_subgroups()]
20		#'
21		#' @examples
22		#' library(dplyr)
23		#' library(forcats)
24		#'
25		#' adrs <- tern_ex_adrs
26		#' adrs_labels <- formatters::var_labels(adrs)
27		#'
28		#' adrs_f <- adrs %>%
29		#' filter(PARAMCD == "BESRSPI") %>%
30		#' filter(ARM %in% c("A: Drug X", "B: Placebo")) %>%
31		#' droplevels() %>%
32		#' mutate(
33		#' # Reorder levels of factor to make the placebo group the reference arm.
34		#' ARM = fct_relevel(ARM, "B: Placebo"),
35		#' rsp = AVALC == "CR"
36		#' )
37		#' formatters::var_labels(adrs_f) <- c(adrs_labels, "Response")
38		#'
39		#' # Unstratified analysis.
40		#' df <- extract_rsp_subgroups(
41		#' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
42		#' data = adrs_f
43		#' )
44		#' df
45		NULL
46
47		#' Prepares Response Data for Population Subgroups in Data Frames
48		#'
49		#' @description `r lifecycle::badge("stable")`
50		#'
51		#' Prepares response rates and odds ratios for population subgroups in data frames. Simple wrapper
52		#' for [h_odds_ratio_subgroups_df()] and [h_proportion_subgroups_df()].
53		#' Result is a list of two data frames: `prop` and `or`.
54		#' `variables` corresponds to the names of variables found in `data`, passed as a named
55		#' list and requires elements `rsp`, `arm` and optionally `subgroups` and `strat`.
56		#' `groups_lists` optionally specifies groupings for `subgroups` variables.
57		#'
58		#' @inheritParams argument_convention
59		#' @inheritParams response_subgroups
60		#' @param label_all (`string`)\cr label for the total population analysis.
61		#' @seealso [response_subgroups]
62		#' @export
63		#'
64		#' @examples
65		#' library(dplyr)
66		#' library(forcats)
67		#'
68		#' adrs <- tern_ex_adrs
69		#' adrs_labels <- formatters::var_labels(adrs)
70		#'
71		#' adrs_f <- adrs %>%
72		#' filter(PARAMCD == "BESRSPI") %>%
73		#' filter(ARM %in% c("A: Drug X", "B: Placebo")) %>%
74		#' droplevels() %>%
75		#' mutate(
76		#' # Reorder levels of factor to make the placebo group the reference arm.
77		#' ARM = fct_relevel(ARM, "B: Placebo"),
78		#' rsp = AVALC == "CR"
79		#' )
80		#' formatters::var_labels(adrs_f) <- c(adrs_labels, "Response")
81		#'
82		#' # Unstratified analysis.
83		#' df <- extract_rsp_subgroups(
84		#' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
85		#' data = adrs_f
86		#' )
87		#' df
88		#'
89		#' # Stratified analysis.
90		#' df_strat <- extract_rsp_subgroups(
91		#' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2"), strat = "STRATA1"),
92		#' data = adrs_f
93		#' )
94		#' df_strat
95		#'
96		#' # Grouping of the BMRKR2 levels.
97		#' df_grouped <- extract_rsp_subgroups(
98		#' variables = list(rsp = "rsp", arm = "ARM", subgroups = c("SEX", "BMRKR2")),
99		#' data = adrs_f,
100		#' groups_lists = list(
101		#' BMRKR2 = list(
102		#' "low" = "LOW",
103		#' "low/medium" = c("LOW", "MEDIUM"),
104		#' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
105		#' )
106		#' )
107		#' )
108		#' df_grouped
109		extract_rsp_subgroups <- function(variables,
110		data,
111		groups_lists = list(),
112		conf_level = 0.95,
113		method = NULL,
114		label_all = "All Patients") {
115	10x	df_prop <- h_proportion_subgroups_df(
116	10x	variables,
117	10x	data,
118	10x	groups_lists = groups_lists,
119	10x	label_all = label_all
120		)
121	10x	df_or <- h_odds_ratio_subgroups_df(
122	10x	variables,
123	10x	data,
124	10x	groups_lists = groups_lists,
125	10x	conf_level = conf_level,
126	10x	method = method,
127	10x	label_all = label_all
128		)
129
130	10x	list(prop = df_prop, or = df_or)
131		}
132
133		#' @describeIn response_subgroups Formatted Analysis function used to format the results of [extract_rsp_subgroups()].
134		#' Returns is a list of Formatted Analysis functions with one element per statistic.
135		#'
136		#' @examples
137		#' # Internal function - a_response_subgroups
138		#' \dontrun{
139		#' a_response_subgroups(.formats = list("n" = "xx", "prop" = "xx.xx%"))
140		#' }
141		#'
142		#' @keywords internal
143		a_response_subgroups <- function(.formats = list(
144		n = "xx",
145		n_rsp = "xx",
146		prop = "xx.x%",
147		n_tot = "xx",
148		or = list(format_extreme_values(2L)),
149		ci = list(format_extreme_values_ci(2L)),
150		pval = "x.xxxx \| (<0.0001)"
151		)) {
152	13x	checkmate::assert_list(.formats)
153	13x	checkmate::assert_subset(
154	13x	names(.formats),
155	13x	c("n", "n_rsp", "prop", "n_tot", "or", "ci", "pval")
156		)
157
158	13x	afun_lst <- Map(
159	13x	function(stat, fmt) {
160	86x	if (stat == "ci") {
161	12x	function(df, labelstr = "", ...) {
162	24x	in_rows(.list = combine_vectors(df$lcl, df$ucl), .labels = as.character(df$subgroup), .formats = fmt)
163		}
164		} else {
165	74x	function(df, labelstr = "", ...) {
166	142x	in_rows(.list = as.list(df[[stat]]), .labels = as.character(df$subgroup), .formats = fmt)
167		}
168		}
169		},
170	13x	stat = names(.formats),
171	13x	fmt = .formats
172		)
173
174	13x	afun_lst
175		}
176
177		#' @describeIn response_subgroups table creating function.
178		#' @param df (`list`)\cr of data frames containing all analysis variables. List should be
179		#' created using [extract_rsp_subgroups()].
180		#' @param vars (`character`)\cr the name of statistics to be reported among
181		#' `n` (total number of observations per group),
182		#' `n_rsp` (number of responders per group),
183		#' `prop` (proportion of responders),
184		#' `n_tot` (total number of observations),
185		#' `or` (odds ratio),
186		#' `ci` (confidence interval of odds ratio) and
187		#' `pval` (p value of the effect).
188		#' Note, the statistics `n_tot`, `or` and `ci` are required.
189		#' @export
190		#'
191		#' @examples
192		#' ## Table with default columns.
193		#' basic_table() %>%
194		#' tabulate_rsp_subgroups(df)
195		#'
196		#' ## Table with selected columns.
197		#' basic_table() %>%
198		#' tabulate_rsp_subgroups(
199		#' df = df,
200		#' vars = c("n_tot", "n", "n_rsp", "prop", "or", "ci")
201		#' )
202		tabulate_rsp_subgroups <- function(lyt,
203		df,
204		vars = c("n_tot", "n", "prop", "or", "ci")) {
205	6x	conf_level <- df$or$conf_level[1]
206	6x	method <- if ("pval_label" %in% names(df$or)) {
207	4x	df$or$pval_label[1]
208		} else {
209	2x	NULL
210		}
211
212	6x	afun_lst <- a_response_subgroups()
213	6x	colvars <- d_rsp_subgroups_colvars(vars, conf_level = conf_level, method = method)
214
215	6x	colvars_prop <- list(
216	6x	vars = colvars$vars[names(colvars$labels) %in% c("n", "prop", "n_rsp")],
217	6x	labels = colvars$labels[names(colvars$labels) %in% c("n", "prop", "n_rsp")]
218		)
219	6x	colvars_or <- list(
220	6x	vars = colvars$vars[names(colvars$labels) %in% c("n_tot", "or", "ci", "pval")],
221	6x	labels = colvars$labels[names(colvars$labels) %in% c("n_tot", "or", "ci", "pval")]
222		)
223
224		# Columns from table_prop are optional.
225	6x	if (length(colvars_prop$vars) > 0) {
226	6x	lyt_prop <- split_cols_by(lyt = lyt, var = "arm")
227	6x	lyt_prop <- split_rows_by(
228	6x	lyt = lyt_prop,
229	6x	var = "row_type",
230	6x	split_fun = keep_split_levels("content"),
231	6x	nested = FALSE
232		)
233	6x	lyt_prop <- summarize_row_groups(
234	6x	lyt = lyt_prop,
235	6x	var = "var_label",
236	6x	cfun = afun_lst[names(colvars_prop$labels)]
237		)
238	6x	lyt_prop <- split_cols_by_multivar(
239	6x	lyt = lyt_prop,
240	6x	vars = colvars_prop$vars,
241	6x	varlabels = colvars_prop$labels
242		)
243
244	6x	if ("analysis" %in% df$prop$row_type) {
245	5x	lyt_prop <- split_rows_by(
246	5x	lyt = lyt_prop,
247	5x	var = "row_type",
248	5x	split_fun = keep_split_levels("analysis"),
249	5x	nested = FALSE,
250	5x	child_labels = "hidden"
251		)
252	5x	lyt_prop <- split_rows_by(lyt = lyt_prop, var = "var_label", nested = TRUE)
253	5x	lyt_prop <- analyze_colvars(
254	5x	lyt = lyt_prop,
255	5x	afun = afun_lst[names(colvars_prop$labels)],
256	5x	inclNAs = TRUE
257		)
258		}
259
260	6x	table_prop <- build_table(lyt_prop, df = df$prop)
261		} else {
262	!	table_prop <- NULL
263		}
264
265		# Columns "n_tot", "or", "ci" in table_or are required.
266	6x	lyt_or <- split_cols_by(lyt = lyt, var = "arm")
267	6x	lyt_or <- split_rows_by(
268	6x	lyt = lyt_or,
269	6x	var = "row_type",
270	6x	split_fun = keep_split_levels("content"),
271	6x	nested = FALSE
272		)
273	6x	lyt_or <- split_cols_by_multivar(
274	6x	lyt = lyt_or,
275	6x	vars = colvars_or$vars,
276	6x	varlabels = colvars_or$labels
277		)
278	6x	lyt_or <- summarize_row_groups(
279	6x	lyt = lyt_or,
280	6x	var = "var_label",
281	6x	cfun = afun_lst[names(colvars_or$labels)]
282		) %>%
283	6x	append_topleft("Baseline Risk Factors")
284
285	6x	if ("analysis" %in% df$or$row_type) {
286	5x	lyt_or <- split_rows_by(
287	5x	lyt = lyt_or,
288	5x	var = "row_type",
289	5x	split_fun = keep_split_levels("analysis"),
290	5x	nested = FALSE,
291	5x	child_labels = "hidden"
292		)
293	5x	lyt_or <- split_rows_by(lyt = lyt_or, var = "var_label", nested = TRUE)
294	5x	lyt_or <- analyze_colvars(
295	5x	lyt = lyt_or,
296	5x	afun = afun_lst[names(colvars_or$labels)],
297	5x	inclNAs = TRUE
298		)
299		}
300	6x	table_or <- build_table(lyt_or, df = df$or)
301
302	6x	n_tot_id <- match("n_tot", colvars_or$vars)
303	6x	if (is.null(table_prop)) {
304	!	result <- table_or
305	!	or_id <- match("or", colvars_or$vars)
306	!	ci_id <- match("lcl", colvars_or$vars)
307		} else {
308	6x	result <- cbind_rtables(table_or[, n_tot_id], table_prop, table_or[, -n_tot_id])
309	6x	or_id <- 1L + ncol(table_prop) + match("or", colvars_or$vars[-n_tot_id])
310	6x	ci_id <- 1L + ncol(table_prop) + match("lcl", colvars_or$vars[-n_tot_id])
311	6x	n_tot_id <- 1L
312		}
313	6x	structure(
314	6x	result,
315	6x	forest_header = paste0(levels(df$prop$arm), "\nBetter"),
316	6x	col_x = or_id,
317	6x	col_ci = ci_id,
318	6x	col_symbol_size = n_tot_id
319		)
320		}
321
322		#' Labels for Column Variables in Binary Response by Subgroup Table
323		#'
324		#' @description `r lifecycle::badge("stable")`
325		#'
326		#' Internal function to check variables included in
327		#' [tabulate_rsp_subgroups] and create column labels.
328		#'
329		#' @inheritParams argument_convention
330		#' @inheritParams tabulate_rsp_subgroups
331		#'
332		#' @return `list` of variables to tabulate and their labels.
333		#'
334		#' @export
335		d_rsp_subgroups_colvars <- function(vars,
336		conf_level = NULL,
337		method = NULL) {
338	13x	checkmate::assert_character(vars)
339	13x	checkmate::assert_subset(c("n_tot", "or", "ci"), vars)
340	13x	checkmate::assert_subset(
341	13x	vars,
342	13x	c("n", "n_rsp", "prop", "n_tot", "or", "ci", "pval")
343		)
344
345	13x	varlabels <- c(
346	13x	n = "n",
347	13x	n_rsp = "Responders",
348	13x	prop = "Response (%)",
349	13x	n_tot = "Total n",
350	13x	or = "Odds Ratio"
351		)
352	13x	colvars <- vars
353
354	13x	if ("ci" %in% colvars) {
355	13x	checkmate::assert_false(is.null(conf_level))
356
357	13x	varlabels <- c(
358	13x	varlabels,
359	13x	ci = paste0(100 * conf_level, "% CI")
360		)
361
362		# The `lcl`` variable is just a placeholder available in the analysis data,
363		# it is not acutally used in the tabulation.
364		# Variables used in the tabulation are lcl and ucl, see `a_response_subgroups` for details.
365	13x	colvars[colvars == "ci"] <- "lcl"
366		}
367
368	13x	if ("pval" %in% colvars) {
369	10x	varlabels <- c(
370	10x	varlabels,
371	10x	pval = method
372		)
373		}
374
375	13x	list(
376	13x	vars = colvars,
377	13x	labels = varlabels[vars]
378		)
379		}

1		#' @include control_step.R
2		NULL
3
4		#' Helper Functions for Subgroup Treatment Effect Pattern (STEP) Calculations
5		#'
6		#' @description`r lifecycle::badge("stable")`
7		#'
8		#' Helper functions that are used internally for the STEP calculations.
9		#'
10		#' @inheritParams argument_convention
11		#' @name h_step
12		#'
13		NULL
14
15		#' @describeIn h_step creates the windows for STEP, based on the control settings
16		#' provided. Returns a list containing the window-selection matrix `sel`
17		#' and the interval information matrix `interval`.
18		#'
19		#' @param x (`numeric`)\cr biomarker value(s) to use (without `NA`).
20		#' @param control (named `list`)\cr output from `control_step()`.
21		#'
22		#' @export
23		h_step_window <- function(x,
24		control = control_step()) {
25	12x	checkmate::assert_numeric(x, min.len = 1, any.missing = FALSE)
26	12x	checkmate::assert_list(control, names = "named")
27
28	12x	sel <- matrix(FALSE, length(x), control$num_points)
29	12x	out <- matrix(0, control$num_points, 3)
30	12x	colnames(out) <- paste("Interval", c("Center", "Lower", "Upper"))
31	12x	if (control$use_percentile) {
32		# Create windows according to percentile cutoffs.
33	9x	out <- cbind(out, out)
34	9x	colnames(out)[1:3] <- paste("Percentile", c("Center", "Lower", "Upper"))
35	9x	xs <- seq(0, 1, length = control$num_points + 2)[-1]
36	9x	for (i in seq_len(control$num_points)) {
37	185x	out[i, 2:3] <- c(
38	185x	max(xs[i] - control$bandwidth, 0),
39	185x	min(xs[i] + control$bandwidth, 1)
40		)
41	185x	out[i, 5:6] <- stats::quantile(x, out[i, 2:3])
42	185x	sel[, i] <- x >= out[i, 5] & x <= out[i, 6]
43		}
44		# Center is the middle point of the percentile window.
45	9x	out[, 1] <- xs[-control$num_points - 1]
46	9x	out[, 4] <- stats::quantile(x, out[, 1])
47		} else {
48		# Create windows according to cutoffs.
49	3x	m <- c(min(x), max(x))
50	3x	xs <- seq(m[1], m[2], length = control$num_points + 2)[-1]
51	3x	for (i in seq_len(control$num_points)) {
52	11x	out[i, 2:3] <- c(
53	11x	max(xs[i] - control$bandwidth, m[1]),
54	11x	min(xs[i] + control$bandwidth, m[2])
55		)
56	11x	sel[, i] <- x >= out[i, 2] & x <= out[i, 3]
57		}
58		# Center is the same as the point for predicting.
59	3x	out[, 1] <- xs[-control$num_points - 1]
60		}
61	12x	list(sel = sel, interval = out)
62		}
63
64		#' @describeIn h_step calculates the estimated treatment effect estimate
65		#' on the linear predictor scale and corresponding standard error from a STEP `model` fitted
66		#' on `data` given `variables` specification, for a single biomarker value `x`.
67		#' This works for both `coxph` and `glm` models, i.e. for calculating log hazard ratio or log odds
68		#' ratio estimates. It returns a vector with elements `est` and `se`.
69		#' @param model the regression model object.
70		#'
71		#' @export
72		h_step_trt_effect <- function(data,
73		model,
74		variables,
75		x) {
76	208x	checkmate::assert_multi_class(model, c("coxph", "glm"))
77	208x	checkmate::assert_number(x)
78	208x	assert_df_with_variables(data, variables)
79	208x	checkmate::assert_factor(data[[variables$arm]], n.levels = 2)
80
81	208x	newdata <- data[c(1, 1), ]
82	208x	newdata[, variables$biomarker] <- x
83	208x	newdata[, variables$arm] <- levels(data[[variables$arm]])
84	208x	model_terms <- stats::delete.response(stats::terms(model))
85	208x	model_frame <- stats::model.frame(model_terms, data = newdata, xlev = model$xlevels)
86	208x	mat <- stats::model.matrix(model_terms, data = model_frame, contrasts.arg = model$contrasts)
87	208x	coefs <- stats::coef(model)
88		# Note: It is important to use the coef subset from matrix, otherwise intercept and
89		# strata are included for coxph() models.
90	208x	mat <- mat[, names(coefs)]
91	208x	mat_diff <- diff(mat)
92	208x	est <- mat_diff %*% coefs
93	208x	var <- mat_diff %% stats::vcov(model) %% t(mat_diff)
94	208x	se <- sqrt(var)
95	208x	c(
96	208x	est = est,
97	208x	se = se
98		)
99		}
100
101		#' @describeIn h_step builds the model formula used in survival STEP calculations.
102		#'
103		#' @export
104		h_step_survival_formula <- function(variables,
105		control = control_step()) {
106	10x	checkmate::assert_character(variables$covariates, null.ok = TRUE)
107
108	10x	assert_list_of_variables(variables[c("arm", "biomarker", "event", "time")])
109	10x	form <- paste0("Surv(", variables$time, ", ", variables$event, ") ~ ", variables$arm)
110	10x	if (control$degree > 0) {
111	5x	form <- paste0(form, " * stats::poly(", variables$biomarker, ", degree = ", control$degree, ", raw = TRUE)")
112		}
113	10x	if (!is.null(variables$covariates)) {
114	6x	form <- paste(form, "+", paste(variables$covariates, collapse = "+"))
115		}
116	10x	if (!is.null(variables$strata)) {
117	2x	form <- paste0(form, " + strata(", paste0(variables$strata, collapse = ", "), ")")
118		}
119	10x	stats::as.formula(form)
120		}
121
122		#' @describeIn h_step estimates the model with `formula` built based on
123		#' `variables` in `data` for a given `subset` and `control` parameters for the
124		#' Cox regression, and returns a matrix of number of observations `n`,
125		#' `events` as well as log hazard ratio estimates `loghr`, standard error `se`
126		#' and Wald confidence interval bounds `ci_lower` and `ci_upper`. One row is
127		#' included here for each biomarker value in `x`.
128		#' @param formula (`formula`)\cr the regression model formula.
129		#' @param subset (`logical`)\cr subset vector.
130		#'
131		#' @export
132		h_step_survival_est <- function(formula,
133		data,
134		variables,
135		x,
136		subset = rep(TRUE, nrow(data)),
137		control = control_coxph()) {
138	55x	checkmate::assert_formula(formula)
139	55x	assert_df_with_variables(data, variables)
140	55x	checkmate::assert_logical(subset, min.len = 1, any.missing = FALSE)
141	55x	checkmate::assert_numeric(x, min.len = 1, any.missing = FALSE)
142	55x	checkmate::assert_list(control, names = "named")
143
144		# Note: `subset` in `coxph` needs to be an expression referring to `data` variables.
145	55x	data$.subset <- subset
146	55x	coxph_warnings <- NULL
147	55x	tryCatch(
148	55x	withCallingHandlers(
149	55x	expr = {
150	55x	fit <- survival::coxph(
151	55x	formula = formula,
152	55x	data = data,
153	55x	subset = .subset,
154	55x	ties = control$ties
155		)
156		},
157	55x	warning = function(w) {
158	1x	coxph_warnings <<- c(coxph_warnings, w)
159	1x	invokeRestart("muffleWarning")
160		}
161		),
162	55x	finally = {
163		}
164		)
165	55x	if (!is.null(coxph_warnings)) {
166	1x	warning(paste(
167	1x	"Fit warnings occurred, please consider using a simpler model, or",
168	1x	"larger `bandwidth`, less `num_points` in `control_step()` settings"
169		))
170		}
171		# Produce a matrix with one row per `x` and columns `est` and `se`.
172	55x	estimates <- t(vapply(
173	55x	X = x,
174	55x	FUN = h_step_trt_effect,
175	55x	FUN.VALUE = c(1, 2),
176	55x	data = data,
177	55x	model = fit,
178	55x	variables = variables
179		))
180	55x	q_norm <- stats::qnorm((1 + control$conf_level) / 2)
181	55x	cbind(
182	55x	n = fit$n,
183	55x	events = fit$nevent,
184	55x	loghr = estimates[, "est"],
185	55x	se = estimates[, "se"],
186	55x	ci_lower = estimates[, "est"] - q_norm * estimates[, "se"],
187	55x	ci_upper = estimates[, "est"] + q_norm * estimates[, "se"]
188		)
189		}
190
191		#' @describeIn h_step builds the model formula used in response STEP calculations.
192		#'
193		#' @export
194		h_step_rsp_formula <- function(variables,
195		control = c(control_step(), control_logistic())) {
196	14x	checkmate::assert_character(variables$covariates, null.ok = TRUE)
197	14x	assert_list_of_variables(variables[c("arm", "biomarker", "response")])
198	14x	response_definition <- sub(
199	14x	pattern = "response",
200	14x	replacement = variables$response,
201	14x	x = control$response_definition,
202	14x	fixed = TRUE
203		)
204	14x	form <- paste0(response_definition, " ~ ", variables$arm)
205	14x	if (control$degree > 0) {
206	8x	form <- paste0(form, " * stats::poly(", variables$biomarker, ", degree = ", control$degree, ", raw = TRUE)")
207		}
208	14x	if (!is.null(variables$covariates)) {
209	8x	form <- paste(form, "+", paste(variables$covariates, collapse = "+"))
210		}
211	14x	if (!is.null(variables$strata)) {
212	5x	strata_arg <- if (length(variables$strata) > 1) {
213	2x	paste0("I(interaction(", paste0(variables$strata, collapse = ", "), "))")
214		} else {
215	3x	variables$strata
216		}
217	5x	form <- paste0(form, "+ strata(", strata_arg, ")")
218		}
219	14x	stats::as.formula(form)
220		}
221
222		#' @describeIn h_step estimates the model with `formula` built based on
223		#' `variables` in `data` for a given `subset` and `control` parameters for the
224		#' logistic regression, and returns a matrix of number of observations `n`
225		#' as well as log odds ratio estimates `logor`, standard error `se`
226		#' and Wald confidence interval bounds `ci_lower` and `ci_upper`. One row is
227		#' included here for each biomarker value in `x`.
228		#' @param formula (`formula`)\cr the regression model formula.
229		#' @param subset (`logical`)\cr subset vector.
230		#'
231		#' @export
232		h_step_rsp_est <- function(formula,
233		data,
234		variables,
235		x,
236		subset = rep(TRUE, nrow(data)),
237		control = control_logistic()) {
238	58x	checkmate::assert_formula(formula)
239	58x	assert_df_with_variables(data, variables)
240	58x	checkmate::assert_logical(subset, min.len = 1, any.missing = FALSE)
241	58x	checkmate::assert_numeric(x, min.len = 1, any.missing = FALSE)
242	58x	checkmate::assert_list(control, names = "named")
243		# Note: `subset` in `glm` needs to be an expression referring to `data` variables.
244	58x	data$.subset <- subset
245	58x	fit_warnings <- NULL
246	58x	tryCatch(
247	58x	withCallingHandlers(
248	58x	expr = {
249	58x	fit <- if (is.null(variables$strata)) {
250	54x	stats::glm(
251	54x	formula = formula,
252	54x	data = data,
253	54x	subset = .subset,
254	54x	family = stats::binomial("logit")
255		)
256		} else {
257		# clogit needs coxph and strata imported
258	4x	survival::clogit(
259	4x	formula = formula,
260	4x	data = data,
261	4x	subset = .subset
262		)
263		}
264		},
265	58x	warning = function(w) {
266	19x	fit_warnings <<- c(fit_warnings, w)
267	19x	invokeRestart("muffleWarning")
268		}
269		),
270	58x	finally = {
271		}
272		)
273	58x	if (!is.null(fit_warnings)) {
274	13x	warning(paste(
275	13x	"Fit warnings occurred, please consider using a simpler model, or",
276	13x	"larger `bandwidth`, less `num_points` in `control_step()` settings"
277		))
278		}
279		# Produce a matrix with one row per `x` and columns `est` and `se`.
280	58x	estimates <- t(vapply(
281	58x	X = x,
282	58x	FUN = h_step_trt_effect,
283	58x	FUN.VALUE = c(1, 2),
284	58x	data = data,
285	58x	model = fit,
286	58x	variables = variables
287		))
288	58x	q_norm <- stats::qnorm((1 + control$conf_level) / 2)
289	58x	cbind(
290	58x	n = length(fit$y),
291	58x	logor = estimates[, "est"],
292	58x	se = estimates[, "se"],
293	58x	ci_lower = estimates[, "est"] - q_norm * estimates[, "se"],
294	58x	ci_upper = estimates[, "est"] + q_norm * estimates[, "se"]
295		)
296		}

1		#' Cumulative Counts with Thresholds
2		#'
3		#' @description `r lifecycle::badge("stable")`
4		#'
5		#' Summarize cumulative counts of a (`numeric`) vector that is less than, less or equal to,
6		#' greater than, or greater or equal to user-specific thresholds.
7		#'
8		#' @seealso Relevant helper function [h_count_cumulative()], and descriptive function [d_count_cumulative()]
9		#'
10		#' @name count_cumulative
11		NULL
12
13		#' Helper Function for [s_count_cumulative()]
14		#'
15		#' @description `r lifecycle::badge("stable")`
16		#'
17		#' Helper function to calculate count and fraction of `x` values in the lower or upper tail given a threshold.
18		#'
19		#' @inheritParams argument_convention
20		#' @param threshold (`number`)\cr a cutoff value as threshold to count values of `x`.
21		#' @param lower_tail (`logical`)\cr whether to count lower tail, default is `TRUE`.
22		#' @param include_eq (`logical`)\cr whether to include value equal to the `threshold` in
23		#' count, default is `TRUE`.
24		#' @param .N_col (`count`)\cr denominator for fraction calculation.
25		#' @return A named vector with items:
26		#' \describe{
27		#' \item{count}{the count of values less than, less or equal to, greater than, or greater or equal to a threshold
28		#' of user specification.
29		#' }
30		#' \item{fraction}{the fraction of the count.}
31		#' }
32		#' @seealso [count_cumulative]
33		#'
34		#' @export
35		#'
36		#' @examples
37		#' set.seed(1, kind = "Mersenne-Twister")
38		#' x <- c(sample(1:10, 10), NA)
39		#' .N_col <- length(x)
40		#' h_count_cumulative(x, 5, .N_col = .N_col)
41		#' h_count_cumulative(x, 5, lower_tail = FALSE, include_eq = FALSE, na.rm = FALSE, .N_col = .N_col)
42		#' h_count_cumulative(x, 0, lower_tail = FALSE, .N_col = .N_col)
43		#' h_count_cumulative(x, 100, lower_tail = FALSE, .N_col = .N_col)
44		h_count_cumulative <- function(x,
45		threshold,
46		lower_tail = TRUE,
47		include_eq = TRUE,
48		na.rm = TRUE, # nolint
49		.N_col) { # nolint
50	20x	checkmate::assert_numeric(x)
51	20x	checkmate::assert_numeric(threshold)
52	20x	checkmate::assert_numeric(.N_col)
53	20x	checkmate::assert_flag(lower_tail)
54	20x	checkmate::assert_flag(include_eq)
55	20x	checkmate::assert_flag(na.rm)
56
57	20x	is_keep <- if (na.rm) !is.na(x) else rep(TRUE, length(x))
58	20x	count <- if (lower_tail && include_eq) {
59	7x	length(x[is_keep & x <= threshold])
60	20x	} else if (lower_tail && !include_eq) {
61	!	length(x[is_keep & x < threshold])
62	20x	} else if (!lower_tail && include_eq) {
63	6x	length(x[is_keep & x >= threshold])
64	20x	} else if (!lower_tail && !include_eq) {
65	7x	length(x[is_keep & x > threshold])
66		}
67
68	20x	result <- c(count = count, fraction = count / .N_col)
69	20x	result
70		}
71
72		#' Description of Cumulative Count
73		#'
74		#' @description `r lifecycle::badge("stable")`
75		#'
76		#' This is a helper function that describes analysis in [s_count_cumulative()].
77		#'
78		#' @inheritParams h_count_cumulative
79		#' @return a descriptive `string`.
80		#' @seealso [s_count_cumulative()]
81		#'
82		#' @export
83		d_count_cumulative <- function(threshold, lower_tail, include_eq) {
84	18x	checkmate::assert_numeric(threshold)
85	18x	lg <- if (lower_tail) "<" else ">"
86	18x	eq <- if (include_eq) "=" else ""
87	18x	paste0(lg, eq, " ", threshold)
88		}
89
90		#' @describeIn count_cumulative Statistics function that produces a named lists given a numeric vector of thresholds.
91		#'
92		#' @inheritParams h_count_cumulative
93		#' @param thresholds (`numeric`)\cr vector of cutoff value for the counts.
94		#' @return A named list of `count_fraction`s: a list with each `thresholds` value as a component, each component
95		#' contains a vector for the count and fraction.
96		#'
97		#' @examples
98		#' # Internal function - s_count_cumulative
99		#' \dontrun{
100		#' set.seed(1, kind = "Mersenne-Twister")
101		#' x <- c(sample(1:10, 10), NA)
102		#' .N_col <- length(x)
103		#' s_count_cumulative(x, thresholds = c(0, 5, 11), .N_col = .N_col)
104		#' s_count_cumulative(x, thresholds = c(0, 5, 11), include_eq = FALSE, na.rm = FALSE, .N_col = .N_col)
105		#' }
106		#'
107		#' @keywords internal
108		s_count_cumulative <- function(x,
109		thresholds,
110		lower_tail = TRUE,
111		include_eq = TRUE,
112		.N_col, # nolint
113		...) {
114	5x	checkmate::assert_numeric(thresholds, min.len = 1, any.missing = FALSE)
115
116	5x	count_fraction_list <- Map(function(thres) {
117	10x	result <- h_count_cumulative(x, thres, lower_tail, include_eq, .N_col = .N_col, ...)
118	10x	label <- d_count_cumulative(thres, lower_tail, include_eq)
119	10x	formatters::with_label(result, label)
120	5x	}, thresholds)
121
122	5x	names(count_fraction_list) <- thresholds
123	5x	list(count_fraction = count_fraction_list)
124		}
125
126		#' @describeIn count_cumulative Formatted Analysis function which can be further customized by calling
127		#' [rtables::make_afun()] on it. It is used as `afun` in [rtables::analyze()].
128		#'
129		#' @return [a_count_cumulative()] returns the corresponding list with formatted [rtables::CellValue()].
130		#'
131		#' @examples
132		#' # Internal function - a_count_cumulative
133		#' \dontrun{
134		#' # Use the Formatted Analysis function for `analyze()`. We need to ungroup `count_fraction` first
135		#' # so that the `rtables` formatting function `format_count_fraction()` can be applied correctly.
136		#' afun <- make_afun(a_count_cumulative, .ungroup_stats = "count_fraction")
137		#' afun(x, thresholds = c(0, 5, 11), .N_col = .N_col)
138		#' }
139		#'
140		#' @keywords internal
141		a_count_cumulative <- make_afun(
142		s_count_cumulative,
143		.formats = c(count_fraction = format_count_fraction)
144		)
145
146		#' @describeIn count_cumulative Layout creating function which can be be used for creating
147		#' summary tables for cumulative counts of a variable. The ellipsis (`...`) conveys
148		#' arguments to `s_count_cumulative()`, for instance `lower_tail = FALSE` if upper tail
149		#' should be accounted for.
150		#'
151		#' @inheritParams argument_convention
152		#' @export
153		#'
154		#' @examples
155		#' basic_table() %>%
156		#' split_cols_by("ARM") %>%
157		#' add_colcounts() %>%
158		#' count_cumulative(
159		#' vars = "AGE",
160		#' thresholds = c(40, 60)
161		#' ) %>%
162		#' build_table(tern_ex_adsl)
163		count_cumulative <- function(lyt,
164		vars,
165		var_labels = vars,
166		show_labels = "visible",
167		...,
168		table_names = vars,
169		.stats = NULL,
170		.formats = NULL,
171		.labels = NULL,
172		.indent_mods = NULL) {
173	2x	afun <- make_afun(
174	2x	a_count_cumulative,
175	2x	.stats = .stats,
176	2x	.formats = .formats,
177	2x	.labels = .labels,
178	2x	.indent_mods = .indent_mods,
179	2x	.ungroup_stats = "count_fraction"
180		)
181	2x	analyze(
182	2x	lyt,
183	2x	vars,
184	2x	afun = afun,
185	2x	table_names = table_names,
186	2x	var_labels = var_labels,
187	2x	show_labels = show_labels,
188	2x	extra_args = list(...)
189		)
190		}

1		#' Horizontal Waterfall Plot
2		#'
3		#' This basic waterfall plot visualizes a quantity \code{height} ordered by value with some
4		#' markup.
5		#'
6		#' @description `r lifecycle::badge("stable")`
7		#'
8		#' @param height (`numeric``)\cr vector containing values to be plotted as the waterfall bars.
9		#' @param id (`character`)\cr vector containing IDs to use as the x-axis label for the waterfall bars.
10		#' @param col (`character`)\cr colors.
11		#' @param col_var (`factor`, `character` or `NULL`)\cr categorical variable for bar coloring. `NULL` by default.
12		#' @param xlab (`character`)\cr x label. Default is `"ID"`.
13		#' @param ylab (`character`)\cr y label. Default is `"Value"`.
14		#' @param title (`character`)\cr text to be displayed as plot title.
15		#' @param col_legend_title (`character`)\cr text to be displayed as legend title.
16		#' @return (`ggplot` object)\cr waterfall plot.
17		#' @template author_song24
18		#'
19		#' @export
20		#'
21		#' @examples
22		#' library(dplyr)
23		#' library(nestcolor)
24		#'
25		#' g_waterfall(height = c(3, 5, -1), id = letters[1:3])
26		#'
27		#' g_waterfall(
28		#' height = c(3, 5, -1),
29		#' id = letters[1:3],
30		#' col_var = letters[1:3]
31		#' )
32		#'
33		#' adsl_f <- tern_ex_adsl %>%
34		#' select(USUBJID, STUDYID, ARM, ARMCD, SEX)
35		#'
36		#' adrs_f <- tern_ex_adrs %>%
37		#' filter(PARAMCD == "OVRINV") %>%
38		#' mutate(pchg = rnorm(n(), 10, 50))
39		#'
40		#' adrs_f <- head(adrs_f, 30)
41		#' adrs_f <- adrs_f[!duplicated(adrs_f$USUBJID), ]
42		#' head(adrs_f)
43		#'
44		#' g_waterfall(
45		#' height = adrs_f$pchg,
46		#' id = adrs_f$USUBJID,
47		#' col_var = adrs_f$AVALC
48		#' )
49		#'
50		#' g_waterfall(
51		#' height = adrs_f$pchg,
52		#' id = paste("asdfdsfdsfsd", adrs_f$USUBJID),
53		#' col_var = adrs_f$SEX
54		#' )
55		#'
56		#' g_waterfall(
57		#' height = adrs_f$pchg,
58		#' id = paste("asdfdsfdsfsd", adrs_f$USUBJID),
59		#' xlab = "ID",
60		#' ylab = "Percentage Change",
61		#' title = "Waterfall plot"
62		#' )
63		g_waterfall <- function(height,
64		id,
65		col_var = NULL,
66		col = getOption("ggplot2.discrete.colour"),
67		xlab = NULL,
68		ylab = NULL,
69		col_legend_title = NULL,
70		title = NULL) {
71	2x	if (!is.null(col_var)) {
72	1x	check_same_n(height = height, id = id, col_var = col_var)
73		} else {
74	1x	check_same_n(height = height, id = id)
75		}
76
77	2x	checkmate::assert_multi_class(col_var, c("character", "factor"), null.ok = TRUE)
78	2x	checkmate::assert_character(col, null.ok = TRUE)
79
80	2x	xlabel <- deparse(substitute(id))
81	2x	ylabel <- deparse(substitute(height))
82
83	2x	col_label <- if (!missing(col_var)) {
84	1x	deparse(substitute(col_var))
85		}
86
87	2x	xlab <- if (is.null(xlab)) xlabel else xlab
88	2x	ylab <- if (is.null(ylab)) ylabel else ylab
89	2x	col_legend_title <- if (is.null(col_legend_title)) col_label else col_legend_title
90
91	2x	plot_data <- data.frame(
92	2x	height = height,
93	2x	id = as.character(id),
94	2x	col_var = if (is.null(col_var)) "x" else to_n(col_var, length(height)),
95	2x	stringsAsFactors = FALSE
96		)
97
98	2x	plot_data_ord <- plot_data[order(plot_data$height, decreasing = TRUE), ]
99
100	2x	p <- ggplot2::ggplot(plot_data_ord, ggplot2::aes(x = factor(id, levels = id), y = height)) +
101	2x	ggplot2::geom_col() +
102	2x	ggplot2::geom_text(
103	2x	label = format(plot_data_ord$height, digits = 2),
104	2x	vjust = ifelse(plot_data_ord$height >= 0, -0.5, 1.5)
105		) +
106	2x	ggplot2::xlab(xlab) +
107	2x	ggplot2::ylab(ylab) +
108	2x	ggplot2::theme(axis.text.x = ggplot2::element_text(angle = 90, hjust = 0, vjust = .5))
109
110	2x	if (!is.null(col_var)) {
111	1x	p <- p +
112	1x	ggplot2::aes(fill = col_var) +
113	1x	ggplot2::labs(fill = col_legend_title) +
114	1x	ggplot2::theme(
115	1x	legend.position = "bottom",
116	1x	legend.background = ggplot2::element_blank(),
117	1x	legend.title = ggplot2::element_text(face = "bold"),
118	1x	legend.box.background = ggplot2::element_rect(colour = "black")
119		)
120		}
121
122	2x	if (!is.null(col)) {
123	1x	p <- p +
124	1x	ggplot2::scale_fill_manual(values = col)
125		}
126
127	2x	if (!is.null(title)) {
128	1x	p <- p +
129	1x	ggplot2::labs(title = title) +
130	1x	ggplot2::theme(plot.title = ggplot2::element_text(face = "bold"))
131		}
132
133	2x	p
134		}

1		#' Estimation of Proportions
2		#'
3		#' @description `r lifecycle::badge("stable")`
4		#'
5		#' Estimate the proportion of responders within a studied population.
6		#'
7		#' @inheritParams argument_convention
8		#' @seealso [h_proportions]
9		#'
10		#' @name estimate_proportions
11		#'
12		NULL
13
14		#' @describeIn estimate_proportions statistics function estimating a
15		#' proportion along with its confidence interval.
16		#'
17		#' @inheritParams prop_strat_wilson
18		#' @param df (`logical` or `data.frame`)\cr if only a logical vector is used,
19		#' it indicates whether each subject is a responder or not. `TRUE` represents
20		#' a successful outcome. If a `data.frame` is provided, also the `strata` variable
21		#' names must be provided in `variables` as a list element with the strata strings.
22		#' In the case of `data.frame`, the logical vector of responses must be indicated as a
23		#' variable name in `.var`.
24		#' @param method (`string`)\cr the method used to construct the confidence interval
25		#' for proportion of successful outcomes; one of `waldcc`, `wald`, `clopper-pearson`,
26		#' `wilson`, `wilsonc`, `strat_wilson`, `strat_wilsonc`, `agresti-coull` or `jeffreys`.
27		#' @param long (`flag`)\cr a long description is required.
28		#'
29		#' @examples
30		#' # Case with only logical vector.
31		#' rsp_v <- c(1, 0, 1, 0, 1, 1, 0, 0)
32		#' s_proportion(rsp_v)
33		#'
34		#' # Example for Stratified Wilson CI
35		#' nex <- 100 # Number of example rows
36		#' dta <- data.frame(
37		#' "rsp" = sample(c(TRUE, FALSE), nex, TRUE),
38		#' "grp" = sample(c("A", "B"), nex, TRUE),
39		#' "f1" = sample(c("a1", "a2"), nex, TRUE),
40		#' "f2" = sample(c("x", "y", "z"), nex, TRUE),
41		#' stringsAsFactors = TRUE
42		#' )
43		#'
44		#' s_proportion(
45		#' df = dta,
46		#' .var = "rsp",
47		#' variables = list(strata = c("f1", "f2")),
48		#' conf_level = 0.90,
49		#' method = "strat_wilson"
50		#' )
51		#'
52		#' @export
53		s_proportion <- function(df,
54		.var,
55		conf_level = 0.95,
56		method = c(
57		"waldcc", "wald", "clopper-pearson",
58		"wilson", "wilsonc", "strat_wilson", "strat_wilsonc",
59		"agresti-coull", "jeffreys"
60		),
61		weights = NULL,
62		max_iterations = 50,
63		variables = list(strata = NULL),
64		long = FALSE) {
65	125x	method <- match.arg(method)
66	125x	checkmate::assert_flag(long)
67	125x	assert_proportion_value(conf_level)
68
69	125x	if (!is.null(variables$strata)) {
70		# Checks for strata
71	!	if (missing(df)) stop("When doing stratified analysis a data.frame with specific columns is needed.")
72	!	strata_colnames <- variables$strata
73	!	checkmate::assert_character(strata_colnames, null.ok = FALSE)
74	!	strata_vars <- stats::setNames(as.list(strata_colnames), strata_colnames)
75	!	assert_df_with_variables(df, strata_vars)
76
77	!	strata <- interaction(df[strata_colnames])
78	!	strata <- as.factor(strata)
79
80		# Pushing down checks to prop_strat_wilson
81	125x	} else if (checkmate::test_subset(method, c("strat_wilson", "strat_wilsonc"))) {
82	!	stop("To use stratified methods you need to specify the strata variables.")
83		}
84	125x	if (checkmate::test_atomic_vector(df)) {
85	125x	rsp <- as.logical(df)
86		} else {
87	!	rsp <- as.logical(df[[.var]])
88		}
89	125x	n <- sum(rsp)
90	125x	p_hat <- mean(rsp)
91
92	125x	prop_ci <- switch(method,
93	125x	"clopper-pearson" = prop_clopper_pearson(rsp, conf_level),
94	125x	"wilson" = prop_wilson(rsp, conf_level),
95	125x	"wilsonc" = prop_wilson(rsp, conf_level, correct = TRUE),
96	125x	"strat_wilson" = prop_strat_wilson(rsp,
97	125x	strata,
98	125x	weights,
99	125x	conf_level,
100	125x	max_iterations,
101	125x	correct = FALSE
102	125x	)$conf_int,
103	125x	"strat_wilsonc" = prop_strat_wilson(rsp,
104	125x	strata,
105	125x	weights,
106	125x	conf_level,
107	125x	max_iterations,
108	125x	correct = TRUE
109	125x	)$conf_int,
110	125x	"wald" = prop_wald(rsp, conf_level),
111	125x	"waldcc" = prop_wald(rsp, conf_level, correct = TRUE),
112	125x	"agresti-coull" = prop_agresti_coull(rsp, conf_level),
113	125x	"jeffreys" = prop_jeffreys(rsp, conf_level)
114		)
115
116	125x	list(
117	125x	"n_prop" = formatters::with_label(c(n, p_hat), "Responders"),
118	125x	"prop_ci" = formatters::with_label(
119	125x	x = 100 * prop_ci, label = d_proportion(conf_level, method, long = long)
120		)
121		)
122		}
123
124		#' @describeIn estimate_proportions Formatted Analysis function which can be further customized by calling
125		#' [rtables::make_afun()] on it. It is used as `afun` in [rtables::analyze()].
126		#'
127		#' @export
128		a_proportion <- make_afun(
129		s_proportion,
130		.formats = c(n_prop = "xx (xx.x%)", prop_ci = "(xx.x, xx.x)")
131		)
132
133		#' @describeIn estimate_proportions used in a `rtables` pipeline.
134		#' @inheritParams rtables::analyze
135		#' @param ... other arguments are ultimately conveyed to [s_proportion()].
136		#'
137		#' @examples
138		#' dta_test <- data.frame(
139		#' USUBJID = paste0("S", 1:12),
140		#' ARM = rep(LETTERS[1:3], each = 4),
141		#' AVAL = c(A = c(1, 1, 1, 1), B = c(0, 0, 1, 1), C = c(0, 0, 0, 0))
142		#' )
143		#'
144		#' basic_table() %>%
145		#' split_cols_by("ARM") %>%
146		#' estimate_proportion(vars = "AVAL") %>%
147		#' build_table(df = dta_test)
148		#'
149		#' @export
150		estimate_proportion <- function(lyt,
151		vars,
152		...,
153		show_labels = "hidden",
154		table_names = vars,
155		.stats = NULL,
156		.formats = NULL,
157		.labels = NULL,
158		.indent_mods = NULL) {
159	3x	afun <- make_afun(
160	3x	a_proportion,
161	3x	.stats = .stats,
162	3x	.formats = .formats,
163	3x	.labels = .labels,
164	3x	.indent_mods = .indent_mods
165		)
166	3x	analyze(
167	3x	lyt,
168	3x	vars,
169	3x	afun = afun,
170	3x	extra_args = list(...),
171	3x	show_labels = show_labels,
172	3x	table_names = table_names
173		)
174		}
175
176		#' Helper Functions for Calculating Proportion Confidence Intervals
177		#'
178		#' @description `r lifecycle::badge("stable")`
179		#'
180		#' Functions to calculate different proportion confidence intervals for use in [estimate_proportion()].
181		#'
182		#' @inheritParams argument_convention
183		#' @inheritParams estimate_proportions
184		#' @seealso [estimate_proportions], descriptive function [d_proportion()],
185		#' and helper functions [strata_normal_quantile()] and [update_weights_strat_wilson()].
186		#'
187		#' @name h_proportions
188		NULL
189
190		#' @describeIn h_proportions the Wilson interval calls [stats::prop.test()].
191		#' Also referred to as Wilson score interval.
192		#'
193		#' @examples
194		#' rsp <- c(
195		#' TRUE, TRUE, TRUE, TRUE, TRUE,
196		#' FALSE, FALSE, FALSE, FALSE, FALSE
197		#' )
198		#' prop_wilson(rsp, conf_level = 0.9)
199		#'
200		#' @export
201		prop_wilson <- function(rsp, conf_level, correct = FALSE) {
202	5x	y <- stats::prop.test(
203	5x	sum(rsp),
204	5x	length(rsp),
205	5x	correct = correct,
206	5x	conf.level = conf_level
207		)
208
209	5x	as.numeric(y$conf.int)
210		}
211
212		#' @describeIn h_proportions Calculates the stratified Wilson confidence
213		#' interval for unequal proportions as described in
214		#' \insertCite{Yan2010-jt;textual}{tern}
215		#'
216		#' @param strata (`factor`)\cr variable with one level per stratum and same length as `rsp`.
217		#' @param weights (`numeric` or `NULL`)\cr weights for each level of the strata. If `NULL`, they are
218		#' estimated using the iterative algorithm proposed in \insertCite{Yan2010-jt;textual}{tern} that
219		#' minimizes the weighted squared length of the confidence interval.
220		#' @param max_iterations (`count`)\cr maximum number of iterations for the iterative procedure used
221		#' to find estimates of optimal weights.
222		#' @param correct (`flag`)\cr include the continuity correction. For further information, see for example
223		#' [stats::prop.test()].
224		#'
225		#' @examples
226		#' # Stratified Wilson confidence interval with unequal probabilities
227		#'
228		#' set.seed(1)
229		#' rsp <- sample(c(TRUE, FALSE), 100, TRUE)
230		#' strata_data <- data.frame(
231		#' "f1" = sample(c("a", "b"), 100, TRUE),
232		#' "f2" = sample(c("x", "y", "z"), 100, TRUE),
233		#' stringsAsFactors = TRUE
234		#' )
235		#' strata <- interaction(strata_data)
236		#' n_strata <- ncol(table(rsp, strata)) # Number of strata
237		#'
238		#' prop_strat_wilson(
239		#' rsp = rsp, strata = strata,
240		#' conf_level = 0.90
241		#' )
242		#'
243		#' # Not automatic setting of weights
244		#' prop_strat_wilson(
245		#' rsp = rsp, strata = strata,
246		#' weights = rep(1 / n_strata, n_strata),
247		#' conf_level = 0.90
248		#' )
249		#' @references
250		#' - \insertRef{Yan2010-jt}{tern}
251		#'
252		#' @importFrom Rdpack reprompt
253		#'
254		#' @export
255		prop_strat_wilson <- function(rsp,
256		strata,
257		weights = NULL,
258		conf_level = 0.95,
259		max_iterations = NULL,
260		correct = FALSE) {
261	20x	checkmate::assert_logical(rsp, any.missing = FALSE)
262	20x	checkmate::assert_factor(strata, len = length(rsp))
263	20x	assert_proportion_value(conf_level)
264
265	20x	tbl <- table(rsp, strata)
266	20x	n_strata <- ncol(tbl)
267
268		# Checking the weights and maximum number of iterations.
269	20x	do_iter <- FALSE
270	20x	if (is.null(weights)) {
271	6x	weights <- rep(1 / n_strata, n_strata) # Initialization for iterative procedure
272	6x	do_iter <- TRUE
273
274		# Iteration parameters
275	2x	if (is.null(max_iterations)) max_iterations <- 10
276	6x	checkmate::assert_int(max_iterations, na.ok = FALSE, null.ok = FALSE, lower = 1)
277		}
278	20x	checkmate::assert_numeric(weights, lower = 0, upper = 1, any.missing = FALSE, len = ncol(tbl))
279	20x	checkmate::assert_int(sum(weights), lower = 1, upper = 1)
280
281
282	20x	xs <- tbl["TRUE", ]
283	20x	ns <- colSums(tbl)
284	20x	use_stratum <- (ns > 0)
285	20x	ns <- ns[use_stratum]
286	20x	xs <- xs[use_stratum]
287	20x	ests <- xs / ns
288	20x	vars <- ests * (1 - ests) / ns
289
290	20x	strata_qnorm <- strata_normal_quantile(vars, weights, conf_level)
291
292		# Iterative setting of weights if they were not set externally
293	20x	weights_new <- if (do_iter) {
294	6x	update_weights_strat_wilson(vars, strata_qnorm, weights, ns, max_iterations, conf_level)$weights
295		} else {
296	14x	weights
297		}
298
299	20x	strata_conf_level <- 2 * stats::pnorm(strata_qnorm) - 1
300
301	20x	ci_by_strata <- Map(
302	20x	function(x, n) {
303		# Classic Wilson's confidence interval
304	139x	suppressWarnings(stats::prop.test(x, n, correct = correct, conf.level = strata_conf_level)$conf.int)
305		},
306	20x	x = xs,
307	20x	n = ns
308		)
309	20x	lower_by_strata <- sapply(ci_by_strata, "[", 1L)
310	20x	upper_by_strata <- sapply(ci_by_strata, "[", 2L)
311
312	20x	lower <- sum(weights_new * lower_by_strata)
313	20x	upper <- sum(weights_new * upper_by_strata)
314
315		# Return values
316	20x	if (do_iter) {
317	6x	list(
318	6x	conf_int = c(
319	6x	lower = lower,
320	6x	upper = upper
321		),
322	6x	weights = weights_new
323		)
324		} else {
325	14x	list(
326	14x	conf_int = c(
327	14x	lower = lower,
328	14x	upper = upper
329		)
330		)
331		}
332		}
333
334		#' @describeIn h_proportions the Clopper-Pearson interval calls
335		#' [stats::binom.test()]. Also referred to as the `exact` method.
336		#'
337		#' @examples
338		#' prop_clopper_pearson(rsp, conf_level = .95)
339		#'
340		#' @export
341		prop_clopper_pearson <- function(rsp,
342		conf_level) {
343	1x	y <- stats::binom.test(
344	1x	x = sum(rsp),
345	1x	n = length(rsp),
346	1x	conf.level = conf_level
347		)
348	1x	as.numeric(y$conf.int)
349		}
350
351		#' @describeIn h_proportions the Wald interval follows the usual
352		#' textbook definition for a single proportion confidence interval using the
353		#' normal approximation.
354		#'
355		#' @param correct (`flag`)\cr apply continuity correction.
356		#'
357		#' @examples
358		#' prop_wald(rsp, conf_level = 0.95)
359		#' prop_wald(rsp, conf_level = 0.95, correct = TRUE)
360		#'
361		#' @export
362		prop_wald <- function(rsp, conf_level, correct = FALSE) {
363	122x	n <- length(rsp)
364	122x	p_hat <- mean(rsp)
365	122x	z <- stats::qnorm((1 + conf_level) / 2)
366	122x	q_hat <- 1 - p_hat
367	122x	correct <- if (correct) 1 / (2 * n) else 0
368
369	122x	err <- z * sqrt(p_hat * q_hat) / sqrt(n) + correct
370	122x	l_ci <- max(0, p_hat - err)
371	122x	u_ci <- min(1, p_hat + err)
372
373	122x	c(l_ci, u_ci)
374		}
375
376		#' @describeIn h_proportions the Agresti-Coull interval was created by
377		#' Alan Agresti and Brent Coull and can be understood (for 95% CI) as adding
378		#' two successes and two failures to the data, and then using the Wald
379		#' formula to construct a CI.
380		#'
381		#' @examples
382		#' prop_agresti_coull(rsp, conf_level = 0.95)
383		#'
384		#' @export
385		prop_agresti_coull <- function(rsp, conf_level) {
386	2x	n <- length(rsp)
387	2x	x_sum <- sum(rsp)
388	2x	z <- stats::qnorm((1 + conf_level) / 2)
389
390		# Add here both z^2 / 2 successes and failures.
391	2x	x_sum_tilde <- x_sum + z^2 / 2
392	2x	n_tilde <- n + z^2
393
394		# Then proceed as with the Wald interval.
395	2x	p_tilde <- x_sum_tilde / n_tilde
396	2x	q_tilde <- 1 - p_tilde
397	2x	err <- z * sqrt(p_tilde * q_tilde) / sqrt(n_tilde)
398	2x	l_ci <- max(0, p_tilde - err)
399	2x	u_ci <- min(1, p_tilde + err)
400
401	2x	c(l_ci, u_ci)
402		}
403
404		#' @describeIn h_proportions the Jeffreys interval is an equal-tailed
405		#' interval based on the non-informative Jeffreys prior for a binomial
406		#' proportion.
407		#'
408		#' @examples
409		#' prop_jeffreys(rsp, conf_level = 0.95)
410		#'
411		#' @export
412		prop_jeffreys <- function(rsp,
413		conf_level) {
414	4x	n <- length(rsp)
415	4x	x_sum <- sum(rsp)
416
417	4x	alpha <- 1 - conf_level
418	4x	l_ci <- ifelse(
419	4x	x_sum == 0,
420	4x	0,
421	4x	stats::qbeta(alpha / 2, x_sum + 0.5, n - x_sum + 0.5)
422		)
423
424	4x	u_ci <- ifelse(
425	4x	x_sum == n,
426	4x	1,
427	4x	stats::qbeta(1 - alpha / 2, x_sum + 0.5, n - x_sum + 0.5)
428		)
429
430	4x	c(l_ci, u_ci)
431		}
432
433		#' Description of the Proportion Summary
434		#'
435		#' @description `r lifecycle::badge("stable")`
436		#'
437		#' This is a helper function that describes the analysis in [s_proportion()].
438		#'
439		#' @inheritParams s_proportion
440		#' @param long (`flag`)\cr whether a long or a short (default) description is required.
441		#'
442		#' @return String describing the analysis.
443		#'
444		#' @export
445		d_proportion <- function(conf_level,
446		method,
447		long = FALSE) {
448	137x	label <- paste0(conf_level * 100, "% CI")
449
450	!	if (long) label <- paste(label, "for Response Rates")
451
452	137x	method_part <- switch(method,
453	137x	"clopper-pearson" = "Clopper-Pearson",
454	137x	"waldcc" = "Wald, with correction",
455	137x	"wald" = "Wald, without correction",
456	137x	"wilson" = "Wilson, without correction",
457	137x	"strat_wilson" = "Stratified Wilson, without correction",
458	137x	"wilsonc" = "Wilson, with correction",
459	137x	"strat_wilsonc" = "Stratified Wilson, with correction",
460	137x	"agresti-coull" = "Agresti-Coull",
461	137x	"jeffreys" = "Jeffreys",
462	137x	stop(paste(method, "does not have a description"))
463		)
464
465	137x	paste0(label, " (", method_part, ")")
466		}
467
468		#' Helper Function for the Estimation of Stratified Quantiles
469		#'
470		#' @description `r lifecycle::badge("stable")`
471		#'
472		#' This function wraps the estimation of stratified percentiles when we assume
473		#' the approximation for large numbers. This is necessary only in the case
474		#' proportions for each strata are unequal.
475		#'
476		#' @inheritParams argument_convention
477		#' @inheritParams prop_strat_wilson
478		#'
479		#' @seealso [prop_strat_wilson()]
480		#'
481		#' @examples
482		#' strata_data <- table(data.frame(
483		#' "f1" = sample(c(TRUE, FALSE), 100, TRUE),
484		#' "f2" = sample(c("x", "y", "z"), 100, TRUE),
485		#' stringsAsFactors = TRUE
486		#' ))
487		#' ns <- colSums(strata_data)
488		#' ests <- strata_data["TRUE", ] / ns
489		#' vars <- ests * (1 - ests) / ns
490		#' weights <- rep(1 / length(ns), length(ns))
491		#' strata_normal_quantile(vars, weights, 0.95)
492		#'
493		#' @export
494		strata_normal_quantile <- function(vars, weights, conf_level) {
495	42x	summands <- weights^2 * vars
496		# Stratified quantile
497	42x	sqrt(sum(summands)) / sum(sqrt(summands)) * stats::qnorm((1 + conf_level) / 2)
498		}
499
500		#' Helper Function for the Estimation of Weights for `prop_strat_wilson`
501		#'
502		#' @description `r lifecycle::badge("stable")`
503		#'
504		#' This function wraps the iteration procedure that allows you to estimate
505		#' the weights for each proportional strata. This assumes to minimize the
506		#' weighted squared length of the confidence interval.
507		#'
508		#' @inheritParams prop_strat_wilson
509		#' @param vars (`numeric`)\cr normalized proportions for each strata.
510		#' @param strata_qnorm (`numeric`)\cr initial estimation with identical weights of the quantiles.
511		#' @param initial_weights (`numeric`)\cr initial weights used to calculate `strata_qnorm`. This can
512		#' be optimized in the future if we need to estimate better initial weights.
513		#' @param n_per_strata (`numeric`)\cr number of elements in each strata.
514		#' @param max_iterations (`count`)\cr maximum number of iterations to be tried. Convergence is always checked.
515		#' @param tol (`number`)\cr tolerance threshold for convergence.
516		#'
517		#' @seealso For references and details see [prop_strat_wilson()].
518		#'
519		#' @examples
520		#' vs <- c(0.011, 0.013, 0.012, 0.014, 0.017, 0.018)
521		#' sq <- 0.674
522		#' ws <- rep(1 / length(vs), length(vs))
523		#' ns <- c(22, 18, 17, 17, 14, 12)
524		#'
525		#' update_weights_strat_wilson(vs, sq, ws, ns, 100, 0.95, 0.001)
526		#'
527		#' @export
528		update_weights_strat_wilson <- function(vars,
529		strata_qnorm,
530		initial_weights,
531		n_per_strata,
532		max_iterations = 50,
533		conf_level = 0.95,
534		tol = 0.001) {
535	8x	it <- 0
536	8x	diff_v <- NULL
537
538	8x	while (it < max_iterations) {
539	20x	it <- it + 1
540	20x	weights_new_t <- (1 + strata_qnorm^2 / n_per_strata)^2
541	20x	weights_new_b <- (vars + strata_qnorm^2 / (4 * n_per_strata^2))
542	20x	weights_new <- weights_new_t / weights_new_b
543	20x	weights_new <- weights_new / sum(weights_new)
544	20x	strata_qnorm <- strata_normal_quantile(vars, weights_new, conf_level)
545	20x	diff_v <- c(diff_v, sum(abs(weights_new - initial_weights)))
546	8x	if (diff_v[length(diff_v)] < tol) break
547	12x	initial_weights <- weights_new
548		}
549
550	8x	if (it == max_iterations) {
551	!	warning("The heuristic to find weights did not converge with max_iterations = ", max_iterations)
552		}
553
554	8x	list(
555	8x	"n_it" = it,
556	8x	"weights" = weights_new,
557	8x	"diff_v" = diff_v
558		)
559		}

1		#' Tabulate Survival Duration by Subgroup
2		#'
3		#' @description `r lifecycle::badge("stable")`
4		#'
5		#' Tabulate statistics such as median survival time and hazard ratio for population subgroups.
6		#'
7		#' @details These functions create a layout starting from a data frame which contains
8		#' the required statistics. Tables typically used as part of forest plot.
9		#'
10		#' @inheritParams argument_convention
11		#' @inheritParams survival_coxph_pairwise
12		#' @param data (`data.frame`)\cr the dataset containing the variables to summarize.
13		#' @param groups_lists (named `list` of `list`)\cr optionally contains for each `subgroups` variable a
14		#' list, which specifies the new group levels via the names and the
15		#' levels that belong to it in the character vectors that are elements of the list.
16		#' @param label_all (`string`)\cr label for the total population analysis.
17		#' @param time_unit (`string`)\cr label with unit of median survival time. Default `NULL` skips
18		#' displaying unit.
19		#' @name survival_duration_subgroups
20		#' @seealso [extract_survival_subgroups()]
21		#'
22		#' @examples
23		#' library(dplyr)
24		#' library(forcats)
25		#'
26		#' adtte <- tern_ex_adtte
27		#'
28		#' # Save variable labels before data processing steps.
29		#' adtte_labels <- formatters::var_labels(adtte)
30		#'
31		#' adtte_f <- adtte %>%
32		#' filter(
33		#' PARAMCD == "OS",
34		#' ARM %in% c("B: Placebo", "A: Drug X"),
35		#' SEX %in% c("M", "F")
36		#' ) %>%
37		#' mutate(
38		#' # Reorder levels of ARM to display reference arm before treatment arm.
39		#' ARM = droplevels(fct_relevel(ARM, "B: Placebo")),
40		#' SEX = droplevels(SEX),
41		#' AVALU = as.character(AVALU),
42		#' is_event = CNSR == 0
43		#' )
44		#' labels <- c(
45		#' "ARM" = adtte_labels[["ARM"]],
46		#' "SEX" = adtte_labels[["SEX"]],
47		#' "AVALU" = adtte_labels[["AVALU"]],
48		#' "is_event" = "Event Flag"
49		#' )
50		#' formatters::var_labels(adtte_f)[names(labels)] <- labels
51		#'
52		#' df <- extract_survival_subgroups(
53		#' variables = list(
54		#' tte = "AVAL",
55		#' is_event = "is_event",
56		#' arm = "ARM", subgroups = c("SEX", "BMRKR2")
57		#' ),
58		#' data = adtte_f
59		#' )
60		#' df
61		NULL
62
63		#' Prepares Survival Data for Population Subgroups in Data Frames
64		#'
65		#' @description `r lifecycle::badge("stable")`
66		#'
67		#' Prepares estimates of median survival times and treatment hazard ratios for population subgroups in
68		#' data frames. Simple wrapper for [h_survtime_subgroups_df()] and [h_coxph_subgroups_df()].
69		#' Result is a list of two data frames: `survtime` and `hr`.
70		#' `variables` corresponds to the names of variables found in `data`, passed as a named list and requires elements
71		#' `tte`, `is_event`, `arm` and optionally `subgroups` and `strat`. `groups_lists` optionally specifies
72		#' groupings for `subgroups` variables.
73		#' @export
74		#' @seealso [survival_duration_subgroups]
75		#' @inheritParams argument_convention
76		#' @inheritParams survival_duration_subgroups
77		#' @inheritParams survival_coxph_pairwise
78		#'
79		#' @examples
80		#' library(dplyr)
81		#' library(forcats)
82		#'
83		#' adtte <- tern_ex_adtte
84		#' adtte_labels <- formatters::var_labels(adtte)
85		#'
86		#' adtte_f <- adtte %>%
87		#' filter(
88		#' PARAMCD == "OS",
89		#' ARM %in% c("B: Placebo", "A: Drug X"),
90		#' SEX %in% c("M", "F")
91		#' ) %>%
92		#' mutate(
93		#' # Reorder levels of ARM to display reference arm before treatment arm.
94		#' ARM = droplevels(fct_relevel(ARM, "B: Placebo")),
95		#' SEX = droplevels(SEX),
96		#' AVALU = as.character(AVALU),
97		#' is_event = CNSR == 0
98		#' )
99		#' labels <- c(
100		#' "ARM" = adtte_labels[["ARM"]],
101		#' "SEX" = adtte_labels[["SEX"]],
102		#' "AVALU" = adtte_labels[["AVALU"]],
103		#' "is_event" = "Event Flag"
104		#' )
105		#' formatters::var_labels(adtte_f)[names(labels)] <- labels
106		#'
107		#' df <- extract_survival_subgroups(
108		#' variables = list(
109		#' tte = "AVAL",
110		#' is_event = "is_event",
111		#' arm = "ARM", subgroups = c("SEX", "BMRKR2")
112		#' ),
113		#' data = adtte_f
114		#' )
115		#' df
116		#'
117		#' df_grouped <- extract_survival_subgroups(
118		#' variables = list(
119		#' tte = "AVAL",
120		#' is_event = "is_event",
121		#' arm = "ARM", subgroups = c("SEX", "BMRKR2")
122		#' ),
123		#' data = adtte_f,
124		#' groups_lists = list(
125		#' BMRKR2 = list(
126		#' "low" = "LOW",
127		#' "low/medium" = c("LOW", "MEDIUM"),
128		#' "low/medium/high" = c("LOW", "MEDIUM", "HIGH")
129		#' )
130		#' )
131		#' )
132		#' df_grouped
133		extract_survival_subgroups <- function(variables,
134		data,
135		groups_lists = list(),
136		control = control_coxph(),
137		label_all = "All Patients") {
138	8x	df_survtime <- h_survtime_subgroups_df(
139	8x	variables,
140	8x	data,
141	8x	groups_lists = groups_lists,
142	8x	label_all = label_all
143		)
144	8x	df_hr <- h_coxph_subgroups_df(
145	8x	variables,
146	8x	data,
147	8x	groups_lists = groups_lists,
148	8x	control = control,
149	8x	label_all = label_all
150		)
151
152	8x	list(survtime = df_survtime, hr = df_hr)
153		}
154
155		#' @describeIn survival_duration_subgroups Formatted Analysis function used to format the results of
156		#' [extract_survival_subgroups()]. Returns is a list of Formatted Analysis functions with one element per statistic.
157		#'
158		#' @examples
159		#' # Internal function - a_survival_subgroups
160		#' \dontrun{
161		#' a_survival_subgroups(.formats = list("n" = "xx", "median" = "xx.xx"))
162		#' }
163		#'
164		#' @keywords internal
165		a_survival_subgroups <- function(.formats = list(
166		n = "xx",
167		n_events = "xx",
168		n_tot_events = "xx",
169		median = "xx.x",
170		n_tot = "xx",
171		hr = list(format_extreme_values(2L)),
172		ci = list(format_extreme_values_ci(2L)),
173		pval = "x.xxxx \| (<0.0001)"
174		)) {
175	12x	checkmate::assert_list(.formats)
176	12x	checkmate::assert_subset(
177	12x	names(.formats),
178	12x	c("n", "n_events", "median", "n_tot", "n_tot_events", "hr", "ci", "pval")
179		)
180
181	12x	afun_lst <- Map(
182	12x	function(stat, fmt) {
183	90x	if (stat == "ci") {
184	11x	function(df, labelstr = "", ...) {
185	20x	in_rows(
186	20x	.list = combine_vectors(df$lcl, df$ucl),
187	20x	.labels = as.character(df$subgroup),
188	20x	.formats = fmt
189		)
190		}
191		} else {
192	79x	function(df, labelstr = "", ...) {
193	111x	in_rows(
194	111x	.list = as.list(df[[stat]]),
195	111x	.labels = as.character(df$subgroup),
196	111x	.formats = fmt
197		)
198		}
199		}
200		},
201	12x	stat = names(.formats),
202	12x	fmt = .formats
203		)
204
205	12x	afun_lst
206		}
207
208		#' @describeIn survival_duration_subgroups table creating function.
209		#' @param df (`list`)\cr of data frames containing all analysis variables. List should be
210		#' created using [extract_survival_subgroups()].
211		#' @param vars (`character`)\cr the name of statistics to be reported among
212		#' `n_tot_events` (total number of events per group),
213		#' `n_events` (number of events per group),
214		#' `n_tot` (total number of observations per group),
215		#' `n` (number of observations per group),
216		#' `median` (median survival time),
217		#' `hr` (hazard ratio),
218		#' `ci` (confidence interval of hazard ratio) and
219		#' `pval` (p value of the effect).
220		#' Note, one of the statistics `n_tot` and `n_tot_events`, as well as both `hr` and `ci`
221		#' are required.
222		#' @export
223		#' @examples
224		#'
225		#' ## Table with default columns.
226		#' basic_table() %>%
227		#' tabulate_survival_subgroups(df, time_unit = adtte_f$AVALU[1])
228		#'
229		#' ## Table with a manually chosen set of columns: adding "pval".
230		#' basic_table() %>%
231		#' tabulate_survival_subgroups(
232		#' df = df,
233		#' vars = c("n_tot_events", "n_events", "median", "hr", "ci", "pval"),
234		#' time_unit = adtte_f$AVALU[1]
235		#' )
236		tabulate_survival_subgroups <- function(lyt,
237		df,
238		vars = c("n_tot_events", "n_events", "median", "hr", "ci"),
239		time_unit = NULL) {
240	5x	conf_level <- df$hr$conf_level[1]
241	5x	method <- df$hr$pval_label[1]
242
243	5x	afun_lst <- a_survival_subgroups()
244	5x	colvars <- d_survival_subgroups_colvars(
245	5x	vars,
246	5x	conf_level = conf_level,
247	5x	method = method,
248	5x	time_unit = time_unit
249		)
250
251	5x	colvars_survtime <- list(
252	5x	vars = colvars$vars[names(colvars$labels) %in% c("n", "n_events", "median")],
253	5x	labels = colvars$labels[names(colvars$labels) %in% c("n", "n_events", "median")]
254		)
255	5x	colvars_hr <- list(
256	5x	vars = colvars$vars[names(colvars$labels) %in% c("n_tot", "n_tot_events", "hr", "ci", "pval")],
257	5x	labels = colvars$labels[names(colvars$labels) %in% c("n_tot", "n_tot_events", "hr", "ci", "pval")]
258		)
259
260		# Columns from table_survtime are optional.
261	5x	if (length(colvars_survtime$vars) > 0) {
262	4x	lyt_survtime <- split_cols_by(lyt = lyt, var = "arm")
263	4x	lyt_survtime <- split_rows_by(
264	4x	lyt = lyt_survtime,
265	4x	var = "row_type",
266	4x	split_fun = keep_split_levels("content"),
267	4x	nested = FALSE
268		)
269	4x	lyt_survtime <- summarize_row_groups(
270	4x	lyt = lyt_survtime,
271	4x	var = "var_label",
272	4x	cfun = afun_lst[names(colvars_survtime$labels)]
273		)
274	4x	lyt_survtime <- split_cols_by_multivar(
275	4x	lyt = lyt_survtime,
276	4x	vars = colvars_survtime$vars,
277	4x	varlabels = colvars_survtime$labels
278		)
279
280	4x	if ("analysis" %in% df$survtime$row_type) {
281	3x	lyt_survtime <- split_rows_by(
282	3x	lyt = lyt_survtime,
283	3x	var = "row_type",
284	3x	split_fun = keep_split_levels("analysis"),
285	3x	nested = FALSE,
286	3x	child_labels = "hidden"
287		)
288	3x	lyt_survtime <- split_rows_by(lyt = lyt_survtime, var = "var_label", nested = TRUE)
289	3x	lyt_survtime <- analyze_colvars(
290	3x	lyt = lyt_survtime,
291	3x	afun = afun_lst[names(colvars_survtime$labels)],
292	3x	inclNAs = TRUE
293		)
294		}
295
296	4x	table_survtime <- build_table(lyt_survtime, df = df$survtime)
297		} else {
298	1x	table_survtime <- NULL
299		}
300
301		# Columns "n_tot_events" or "n_tot", and "hr", "ci" in table_hr are required.
302	5x	lyt_hr <- split_cols_by(lyt = lyt, var = "arm")
303	5x	lyt_hr <- split_rows_by(
304	5x	lyt = lyt_hr,
305	5x	var = "row_type",
306	5x	split_fun = keep_split_levels("content"),
307	5x	nested = FALSE
308		)
309	5x	lyt_hr <- summarize_row_groups(
310	5x	lyt = lyt_hr,
311	5x	var = "var_label",
312	5x	cfun = afun_lst[names(colvars_hr$labels)]
313		)
314	5x	lyt_hr <- split_cols_by_multivar(
315	5x	lyt = lyt_hr,
316	5x	vars = colvars_hr$vars,
317	5x	varlabels = colvars_hr$labels
318		) %>%
319	5x	append_topleft("Baseline Risk Factors")
320
321	5x	if ("analysis" %in% df$survtime$row_type) {
322	4x	lyt_hr <- split_rows_by(
323	4x	lyt = lyt_hr,
324	4x	var = "row_type",
325	4x	split_fun = keep_split_levels("analysis"),
326	4x	nested = FALSE,
327	4x	child_labels = "hidden"
328		)
329	4x	lyt_hr <- split_rows_by(lyt = lyt_hr, var = "var_label", nested = TRUE)
330	4x	lyt_hr <- analyze_colvars(
331	4x	lyt = lyt_hr,
332	4x	afun = afun_lst[names(colvars_hr$labels)],
333	4x	inclNAs = TRUE
334		)
335		}
336	5x	table_hr <- build_table(lyt_hr, df = df$hr)
337
338		# There can be one or two vars starting with "n_tot".
339	5x	n_tot_ids <- grep("^n_tot", colvars_hr$vars)
340	5x	if (is.null(table_survtime)) {
341	1x	result <- table_hr
342	1x	hr_id <- match("hr", colvars_hr$vars)
343	1x	ci_id <- match("lcl", colvars_hr$vars)
344		} else {
345		# Reorder the table.
346	4x	result <- cbind_rtables(table_hr[, n_tot_ids], table_survtime, table_hr[, -n_tot_ids])
347		# And then calculate column indices accordingly.
348	4x	hr_id <- length(n_tot_ids) + ncol(table_survtime) + match("hr", colvars_hr$vars[-n_tot_ids])
349	4x	ci_id <- length(n_tot_ids) + ncol(table_survtime) + match("lcl", colvars_hr$vars[-n_tot_ids])
350	4x	n_tot_ids <- seq_along(n_tot_ids)
351		}
352
353	5x	structure(
354	5x	result,
355	5x	forest_header = paste0(rev(levels(df$survtime$arm)), "\nBetter"),
356	5x	col_x = hr_id,
357	5x	col_ci = ci_id,
358		# Take the first one for scaling the symbol sizes in graph.
359	5x	col_symbol_size = n_tot_ids[1]
360		)
361		}
362
363		#' Labels for Column Variables in Survival Duration by Subgroup Table
364		#'
365		#' @description `r lifecycle::badge("stable")`
366		#'
367		#' Internal function to check variables included in
368		#' [tabulate_survival_subgroups()] and create column labels.
369		#' Note that at least one of `n_tot` and `n_tot_events` needs to be provided in `vars`.
370		#'
371		#' @inheritParams tabulate_survival_subgroups
372		#' @inheritParams argument_convention
373		#' @param method p-value method for testing hazard ratio = 1.
374		#' @return `list` of variables to tabulate and their labels.
375		#'
376		#' @export
377		d_survival_subgroups_colvars <- function(vars,
378		conf_level,
379		method,
380		time_unit = NULL) {
381	12x	checkmate::assert_character(vars)
382	12x	checkmate::assert_string(time_unit, null.ok = TRUE)
383	12x	checkmate::assert_subset(c("hr", "ci"), vars)
384	12x	checkmate::assert_true(any(c("n_tot", "n_tot_events") %in% vars))
385	12x	checkmate::assert_subset(
386	12x	vars,
387	12x	c("n", "n_events", "median", "n_tot", "n_tot_events", "hr", "ci", "pval")
388		)
389
390	12x	propcase_time_label <- if (!is.null(time_unit)) {
391	11x	paste0("Median (", time_unit, ")")
392		} else {
393	1x	"Median"
394		}
395
396	12x	varlabels <- c(
397	12x	n = "n",
398	12x	n_events = "Events",
399	12x	median = propcase_time_label,
400	12x	n_tot = "Total n",
401	12x	n_tot_events = "Total Events",
402	12x	hr = "Hazard Ratio",
403	12x	ci = paste0(100 * conf_level, "% Wald CI"),
404	12x	pval = method
405		)
406
407	12x	colvars <- vars
408
409		# The `lcl` variable is just a placeholder available in the analysis data,
410		# it is not acutally used in the tabulation.
411		# Variables used in the tabulation are lcl and ucl, see `a_survival_subgroups` for details.
412	12x	colvars[colvars == "ci"] <- "lcl"
413
414	12x	list(
415	12x	vars = colvars,
416	12x	labels = varlabels[vars]
417		)
418		}

1		#' Difference Test for Two Proportions
2		#'
3		#' @description `r lifecycle::badge("stable")`
4		#'
5		#' Various tests were implemented to test the difference between two
6		#' proportions.
7		#'
8		#' @param tbl (`matrix`)\cr matrix with two groups in rows and the binary response
9		#' (`TRUE`/`FALSE`) in columns.
10		#' @seealso [h_prop_diff_test]
11		#'
12		#' @name prop_diff_test
13		#'
14		NULL
15
16		#' @describeIn prop_diff_test Statistics function which tests the difference
17		#' between two proportions.
18		#'
19		#' @inheritParams argument_convention
20		#' @param method (`string`)\cr one of `chisq`, `cmh`, `fisher`, or `schouten`; specifies the test used
21		#' to calculate the p-value.
22		#'
23		#' @return Named `list` with a single item `pval` with an attribute `label`
24		#' describing the method used. The p-value tests the null hypothesis that
25		#' proportions in two groups are the same.
26		#'
27		#' @examples
28		#'
29		#' # Statistics function
30		#' dta <- data.frame(
31		#' rsp = sample(c(TRUE, FALSE), 100, TRUE),
32		#' grp = factor(rep(c("A", "B"), each = 50)),
33		#' strat = factor(rep(c("V", "W", "X", "Y", "Z"), each = 20))
34		#' )
35		#'
36		#' # Internal function - s_test_proportion_diff
37		#' \dontrun{
38		#' s_test_proportion_diff(
39		#' df = subset(dta, grp == "A"),
40		#' .var = "rsp",
41		#' .ref_group = subset(dta, grp == "B"),
42		#' .in_ref_col = FALSE,
43		#' variables = list(strata = "strat"),
44		#' method = "cmh"
45		#' )
46		#' }
47		#'
48		#' @keywords internal
49		s_test_proportion_diff <- function(df,
50		.var,
51		.ref_group,
52		.in_ref_col,
53		variables = list(strata = NULL),
54		method = c("chisq", "schouten", "fisher", "cmh")) {
55	30x	method <- match.arg(method)
56	30x	y <- list(pval = "")
57
58	30x	if (!.in_ref_col) {
59	30x	assert_df_with_variables(df, list(rsp = .var))
60	30x	assert_df_with_variables(.ref_group, list(rsp = .var))
61	30x	rsp <- factor(
62	30x	c(.ref_group[[.var]], df[[.var]]),
63	30x	levels = c("TRUE", "FALSE")
64		)
65	30x	grp <- factor(
66	30x	rep(c("ref", "Not-ref"), c(nrow(.ref_group), nrow(df))),
67	30x	levels = c("ref", "Not-ref")
68		)
69
70	30x	if (!is.null(variables$strata) \|\| method == "cmh") {
71	12x	strata <- variables$strata
72	12x	checkmate::assert_false(is.null(strata))
73	12x	strata_vars <- stats::setNames(as.list(strata), strata)
74	12x	assert_df_with_variables(df, strata_vars)
75	12x	assert_df_with_variables(.ref_group, strata_vars)
76	12x	strata <- c(interaction(.ref_group[strata]), interaction(df[strata]))
77		}
78
79	30x	tbl <- switch(method,
80	30x	cmh = table(grp, rsp, strata),
81	30x	table(grp, rsp)
82		)
83
84	30x	y$pval <- switch(method,
85	30x	chisq = prop_chisq(tbl),
86	30x	cmh = prop_cmh(tbl),
87	30x	fisher = prop_fisher(tbl),
88	30x	schouten = prop_schouten(tbl)
89		)
90		}
91
92	30x	y$pval <- formatters::with_label(y$pval, d_test_proportion_diff(method))
93	30x	y
94		}
95
96		#' Description of the Difference Test Between Two Proportions
97		#'
98		#' @description `r lifecycle::badge("stable")`
99		#'
100		#' This is an auxiliary function that describes the analysis in
101		#' `s_test_proportion_diff`.
102		#'
103		#' @inheritParams s_test_proportion_diff
104		#' @return `string` describing the test from which the p-value is derived.
105		#'
106		#' @export
107		d_test_proportion_diff <- function(method) {
108	41x	checkmate::assert_string(method)
109	41x	meth_part <- switch(method,
110	41x	"schouten" = "Chi-Squared Test with Schouten Correction",
111	41x	"chisq" = "Chi-Squared Test",
112	41x	"cmh" = "Cochran-Mantel-Haenszel Test",
113	41x	"fisher" = "Fisher's Exact Test",
114	41x	stop(paste(method, "does not have a description"))
115		)
116	41x	paste0("p-value (", meth_part, ")")
117		}
118
119		#' @describeIn prop_diff_test Formatted Analysis function which can be further customized by calling
120		#' [rtables::make_afun()] on it. It is used as `afun` in [rtables::analyze()].
121		#'
122		#' @examples
123		#' # Internal function - a_test_proportion_diff
124		#' \dontrun{
125		#' a_test_proportion_diff(
126		#' df = subset(dta, grp == "A"),
127		#' .var = "rsp",
128		#' .ref_group = subset(dta, grp == "B"),
129		#' .in_ref_col = FALSE,
130		#' variables = list(strata = "strat"),
131		#' method = "cmh"
132		#' )
133		#' }
134		#'
135		#' @keywords internal
136		a_test_proportion_diff <- make_afun(
137		s_test_proportion_diff,
138		.formats = c(pval = "x.xxxx \| (<0.0001)"),
139		.indent_mods = c(pval = 1L)
140		)
141
142		#' @describeIn prop_diff_test Layout creating function which can be used for
143		#' creating tables, which can take statistics function arguments and
144		#' additional format arguments.
145		#' @param ... other arguments are passed to [s_test_proportion_diff()].
146		#' @inheritParams argument_convention
147		#' @export
148		#'
149		#' @examples
150		#' # With `rtables` pipelines.
151		#' l <- basic_table() %>%
152		#' split_cols_by(var = "grp", ref_group = "B") %>%
153		#' test_proportion_diff(
154		#' vars = "rsp",
155		#' method = "cmh", variables = list(strata = "strat")
156		#' )
157		#'
158		#' build_table(l, df = dta)
159		test_proportion_diff <- function(lyt,
160		vars,
161		...,
162		var_labels = vars,
163		show_labels = "hidden",
164		table_names = vars,
165		.stats = NULL,
166		.formats = NULL,
167		.labels = NULL,
168		.indent_mods = NULL) {
169	5x	afun <- make_afun(
170	5x	a_test_proportion_diff,
171	5x	.stats = .stats,
172	5x	.formats = .formats,
173	5x	.labels = .labels,
174	5x	.indent_mods = .indent_mods
175		)
176	5x	analyze(
177	5x	lyt,
178	5x	vars,
179	5x	afun = afun,
180	5x	var_labels = var_labels,
181	5x	extra_args = list(...),
182	5x	show_labels = show_labels,
183	5x	table_names = table_names
184		)
185		}
186
187		#' Helper Functions to Test Proportion Differences
188		#'
189		#' Helper functions to implement various tests on the difference between two
190		#' proportions.
191		#'
192		#' @param tbl (`matrix`)\cr matrix with two groups in rows and the binary response
193		#' (`TRUE`/`FALSE`) in columns.
194		#'
195		#' @seealso [prop_diff_test())] for implementation of these helper functions.
196		#'
197		#' @name h_prop_diff_test
198		NULL
199
200		#' @describeIn h_prop_diff_test performs Chi-Squared test.
201		#' Internally calls [stats::prop.test()].
202		#'
203		#' @examples
204		#' # Non-stratified proportion difference test
205		#'
206		#' ## Data
207		#' A <- 20
208		#' B <- 20
209		#' set.seed(1)
210		#' rsp <- c(
211		#' sample(c(TRUE, FALSE), size = A, prob = c(3 / 4, 1 / 4), replace = TRUE),
212		#' sample(c(TRUE, FALSE), size = A, prob = c(1 / 2, 1 / 2), replace = TRUE)
213		#' )
214		#' grp <- c(rep("A", A), rep("B", B))
215		#' tbl <- table(grp, rsp)
216		#'
217		#' ## Chi-Squared test
218		#' # Internal function - prop_chisq
219		#' \dontrun{
220		#' prop_chisq(tbl)
221		#' }
222		#'
223		#' @keywords internal
224		prop_chisq <- function(tbl) {
225	23x	checkmate::assert_integer(c(ncol(tbl), nrow(tbl)), lower = 2, upper = 2)
226	23x	tbl <- tbl[, c("TRUE", "FALSE")]
227	23x	if (any(colSums(tbl) == 0)) {
228	2x	return(1)
229		}
230	21x	stats::prop.test(tbl, correct = FALSE)$p.value
231		}
232
233		#' @describeIn h_prop_diff_test performs stratified Cochran-Mantel-Haenszel test.
234		#' Internally calls [stats::mantelhaen.test()]. Note that strata with less than two observations
235		#' are automatically discarded.
236		#'
237		#' @param ary (`array`, 3 dimensions)\cr array with two groups in rows, the binary response
238		#' (`TRUE`/`FALSE`) in columns, and the strata in the third dimension.
239		#'
240		#' @examples
241		#' # Stratified proportion difference test
242		#'
243		#' ## Data
244		#' rsp <- sample(c(TRUE, FALSE), 100, TRUE)
245		#' grp <- factor(rep(c("A", "B"), each = 50))
246		#' strata <- factor(rep(c("V", "W", "X", "Y", "Z"), each = 20))
247		#' tbl <- table(grp, rsp, strata)
248		#'
249		#' ## Cochran-Mantel-Haenszel test
250		#' # Internal function - prop_cmh
251		#' \dontrun{
252		#' prop_cmh(tbl)
253		#' }
254		#'
255		#' @keywords internal
256		prop_cmh <- function(ary) {
257	16x	checkmate::assert_array(ary)
258	16x	checkmate::assert_integer(c(ncol(ary), nrow(ary)), lower = 2, upper = 2)
259	16x	checkmate::assert_integer(length(dim(ary)), lower = 3, upper = 3)
260	16x	strata_sizes <- apply(ary, MARGIN = 3, sum)
261	16x	if (any(strata_sizes < 5)) {
262	1x	warning("<5 data points in some strata. CMH test may be incorrect.")
263	1x	ary <- ary[, , strata_sizes > 1]
264		}
265
266	16x	stats::mantelhaen.test(ary, correct = FALSE)$p.value
267		}
268
269		#' @describeIn h_prop_diff_test performs the Chi-Squared test with Schouten
270		#' correction.
271		#'
272		#' @seealso For information on the Schouten correction (Schouten, 1980),
273		#' visit https://onlinelibrary.wiley.com/doi/abs/10.1002/bimj.4710220305.
274		#'
275		#' @examples
276		#' ## Chi-Squared test + Schouten correction.
277		#' # Internal function - prop_schouten
278		#' \dontrun{
279		#' prop_schouten(tbl)
280		#' }
281		#'
282		#' @keywords internal
283		prop_schouten <- function(tbl) {
284	100x	checkmate::assert_integer(c(ncol(tbl), nrow(tbl)), lower = 2, upper = 2)
285	100x	tbl <- tbl[, c("TRUE", "FALSE")]
286	100x	if (any(colSums(tbl) == 0)) {
287	1x	return(1)
288		}
289
290	99x	n <- sum(tbl)
291	99x	n1 <- sum(tbl[1, ])
292	99x	n2 <- sum(tbl[2, ])
293
294	99x	ad <- diag(tbl)
295	99x	bc <- diag(apply(tbl, 2, rev))
296	99x	ac <- tbl[, 1]
297	99x	bd <- tbl[, 2]
298
299	99x	t_schouten <- (n - 1) *
300	99x	(abs(prod(ad) - prod(bc)) - 0.5 * min(n1, n2))^2 /
301	99x	(n1 * n2 * sum(ac) * sum(bd))
302
303	99x	1 - stats::pchisq(t_schouten, df = 1)
304		}
305
306		#' @describeIn h_prop_diff_test performs the Fisher's exact test.
307		#' Internally calls [stats::fisher.test()].
308		#'
309		#' @examples
310		#' ## Fisher's exact test
311		#' # Internal function - prop_fisher
312		#' \dontrun{
313		#' prop_fisher(tbl)
314		#' }
315		#'
316		#' @keywords internal
317		prop_fisher <- function(tbl) {
318	2x	checkmate::assert_integer(c(ncol(tbl), nrow(tbl)), lower = 2, upper = 2)
319	2x	tbl <- tbl[, c("TRUE", "FALSE")]
320	2x	stats::fisher.test(tbl)$p.value
321		}

1		#' Counting Patients Summing Exposure Across All Patients in Columns
2		#'
3		#' @description `r lifecycle::badge("stable")`
4		#'
5		#' Counting the number of patients and summing analysis value (i.e exposure values) across all patients
6		#' when a column table layout is required.
7		#'
8		#' @name summarize_patients_exposure_in_cols
9		#'
10		NULL
11
12		#' @describeIn summarize_patients_exposure_in_cols Statistics function which counts numbers
13		#' of patients and the sum of exposure across all patients.
14		#'
15		#' @inheritParams argument_convention
16		#' @param custom_label (`string` or `NULL`)\cr if provided and `labelstr` is empty then this will
17		#' be used as label.
18		#' @return [s_count_patients_sum_exposure()] returns a list with the statistics:
19		#' \describe{
20		#' \item{n_patients}{number of unique patients in `df`.}
21		#' \item{sum_exposure}{sum of `.var` across all patients in `df`.}
22		#' }
23		#'
24		#' @examples
25		#' set.seed(1)
26		#' df <- data.frame(
27		#' USUBJID = c(paste("id", seq(1, 12), sep = "")),
28		#' ARMCD = c(rep("ARM A", 6), rep("ARM B", 6)),
29		#' SEX = c(rep("Female", 6), rep("Male", 6)),
30		#' AVAL = as.numeric(sample(seq(1, 20), 12)),
31		#' stringsAsFactors = TRUE
32		#' )
33		#' adsl <- data.frame(
34		#' USUBJID = c(paste("id", seq(1, 12), sep = "")),
35		#' ARMCD = c(rep("ARM A", 2), rep("ARM B", 2)),
36		#' SEX = c(rep("Female", 2), rep("Male", 2)),
37		#' stringsAsFactors = TRUE
38		#' )
39		#'
40		#' # Internal function - s_count_patients_sum_exposure
41		#' \dontrun{
42		#' s_count_patients_sum_exposure(df = df, .N_col = nrow(adsl))
43		#' s_count_patients_sum_exposure(
44		#' df = df,
45		#' .N_col = nrow(adsl),
46		#' custom_label = "some user's custom label"
47		#' )
48		#' }
49		#'
50		#' @keywords internal
51		s_count_patients_sum_exposure <- function(df, # nolintr
52		.var = "AVAL",
53		id = "USUBJID",
54		labelstr = "",
55		.N_col, # nolintr
56		custom_label = NULL) {
57	29x	assert_df_with_variables(df, list(.var = .var, id = id))
58	29x	checkmate::assert_string(id)
59	29x	checkmate::assert_string(labelstr)
60	29x	checkmate::assert_string(custom_label, null.ok = TRUE)
61	29x	checkmate::assert_numeric(df[[.var]])
62
63	29x	row_label <- if (labelstr != "") {
64	18x	labelstr
65	29x	} else if (!is.null(custom_label)) {
66	4x	custom_label
67		} else {
68	7x	"Total patients numbers/person time"
69		}
70
71	29x	y <- list()
72
73	29x	y$n_patients <-
74	29x	formatters::with_label(
75	29x	s_num_patients_content(
76	29x	df = df,
77	29x	.N_col = .N_col, # nolintr
78	29x	.var = id,
79	29x	labelstr = ""
80	29x	)$unique,
81	29x	row_label
82		)
83
84	29x	y$sum_exposure <- formatters::with_label(sum(df[[.var]]), row_label)
85	29x	y
86		}
87
88		#' @describeIn summarize_patients_exposure_in_cols Layout creating function which adds the count
89		#' statistics of patients and the sum of analysis value in the column layout as content rows.
90		#'
91		#' @inheritParams argument_convention
92		#' @param col_split (`flag`)\cr whether the columns should be split. Set to `FALSE` when the required
93		#' column split has been done already earlier in the layout pipe.
94		#' @export
95		#'
96		#' @examples
97		#' lyt <- basic_table() %>%
98		#' split_cols_by("ARMCD", split_fun = add_overall_level("Total", first = FALSE)) %>%
99		#' summarize_patients_exposure_in_cols(var = "AVAL", col_split = TRUE) %>%
100		#' split_rows_by("SEX") %>%
101		#' summarize_patients_exposure_in_cols(var = "AVAL", col_split = FALSE)
102		#' result <- build_table(lyt, df = df, alt_counts_df = adsl)
103		#' result
104		#'
105		#' lyt2 <- basic_table() %>%
106		#' split_cols_by("ARMCD", split_fun = add_overall_level("Total", first = FALSE)) %>%
107		#' summarize_patients_exposure_in_cols(
108		#' var = "AVAL", col_split = TRUE,
109		#' .stats = "n_patients", custom_label = "some custom label"
110		#' ) %>%
111		#' split_rows_by("SEX") %>%
112		#' summarize_patients_exposure_in_cols(var = "AVAL", col_split = FALSE)
113		#' result2 <- build_table(lyt2, df = df, alt_counts_df = adsl)
114		#' result2
115		#'
116		#' lyt3 <- basic_table() %>%
117		#' summarize_patients_exposure_in_cols(var = "AVAL", col_split = TRUE)
118		#' result3 <- build_table(lyt3, df = df, alt_counts_df = adsl)
119		#' result3
120		#'
121		#' lyt4 <- basic_table() %>%
122		#' summarize_patients_exposure_in_cols(var = "AVAL", col_split = TRUE, .stats = "sum_exposure")
123		#' result4 <- build_table(lyt4, df = df, alt_counts_df = adsl)
124		#' result4
125		summarize_patients_exposure_in_cols <- function(lyt, # nolintr
126		var,
127		...,
128		.stats = c("n_patients", "sum_exposure"),
129		.labels = c(n_patients = "Patients", sum_exposure = "Person time"),
130		.indent_mods = NULL,
131		col_split = TRUE) {
132	5x	afun_list <- Map(
133	5x	function(stat) {
134	7x	make_afun(
135	7x	s_count_patients_sum_exposure,
136	7x	.stats = stat,
137	7x	.formats = ifelse(stat == "n_patients", "xx (xx.x%)", "xx")
138		)
139		},
140	5x	stat = .stats
141		)
142
143	5x	if (col_split) {
144	3x	lyt <- split_cols_by_multivar(
145	3x	lyt = lyt,
146	3x	vars = rep(var, length(.stats)),
147	3x	varlabels = .labels[.stats]
148		)
149		}
150	5x	summarize_row_groups(
151	5x	lyt = lyt,
152	5x	var = var,
153	5x	cfun = afun_list,
154	5x	extra_args = list(...)
155		)
156		}

1		#' Convert Table into Matrix of Strings
2		#'
3		#' @description `r lifecycle::badge("stable")`
4		#'
5		#' Helper function to use mostly within tests. `with_spaces`parameter allows
6		#' to test not only for content but also indentation and table structure.
7		#' `print_txt_to_copy` instead facilitate the testing development by returning a well
8		#' formatted text that needs only to be copied and pasted in the expected output.
9		#'
10		#' @param x `rtables` table.
11		#' @param with_spaces Should the tested table keep the indentation and other relevant
12		#' spaces?
13		#' @param print_txt_to_copy Utility to have a way to copy the input table directly
14		#' into the expected variable instead of copying it too manually.
15		#'
16		#' @return A matrix of strings
17		#'
18		#' @export
19		to_string_matrix <- function(x, with_spaces = FALSE, print_txt_to_copy = FALSE) {
20	5x	checkmate::assert_flag(with_spaces)
21	5x	checkmate::assert_flag(print_txt_to_copy)
22
23		# Producing the matrix to test
24	5x	if (with_spaces) {
25	!	out <- strsplit(toString(matrix_form(x, TRUE)), "\\n")[[1]]
26		} else {
27	5x	out <- matrix_form(x)$string
28		}
29
30		# Printing to console formatted output that needs to be copied in "expected"
31	5x	if (print_txt_to_copy) {
32	!	out_tmp <- out
33	!	if (!with_spaces) {
34	!	out_tmp <- apply(out, 1, paste0, collapse = '", "')
35		}
36	!	cat(paste0('c(\n "', paste0(out_tmp, collapse = '",\n "'), '"\n)'))
37		}
38
39		# Return values
40	5x	return(out)
41		}
42
43		#' Blank for Missing Input
44		#'
45		#' Helper function to use in tabulating model results.
46		#'
47		#' @param x (`vector`)\cr input for a cell.
48		#'
49		#' @return Either empty character vector if all entries in `x` are missing (`NA`), or otherwise
50		#' the unlisted version of `x`
51		#'
52		#' @keywords internal
53		unlist_and_blank_na <- function(x) {
54	267x	unl <- unlist(x)
55	267x	if (all(is.na(unl))) {
56	161x	character()
57		} else {
58	106x	unl
59		}
60		}
61
62		#' Constructor for Content Functions given Data Frame with Flag Input
63		#'
64		#' This can be useful for tabulating model results.
65		#'
66		#' @param analysis_var (`string`)\cr variable name for the column containing values to be
67		#' returned by the content function.
68		#' @param flag_var (`string`)\cr variable name for the logical column identifying which
69		#' row should be returned.
70		#' @param format (`string`)\cr `rtables` format to use.
71		#'
72		#' @return Content function which just gives `df$analysis_var` at the row identified by
73		#' `.df_row$flag` in the given format.
74		#'
75		#' @keywords internal
76		cfun_by_flag <- function(analysis_var,
77		flag_var,
78		format = "xx") {
79	61x	checkmate::assert_string(analysis_var)
80	61x	checkmate::assert_string(flag_var)
81	61x	function(df, labelstr) {
82	265x	row_index <- which(df[[flag_var]])
83	265x	x <- unlist_and_blank_na(df[[analysis_var]][row_index])
84	265x	formatters::with_label(
85	265x	rcell(x, format = format),
86	265x	labelstr
87		)
88		}
89		}
90
91		#' Content Row Function to Add Row Total to Labels
92		#'
93		#' This takes the label of the latest row split level and adds the row total in parentheses.
94		#'
95		#' @inheritParams argument_convention
96		#'
97		#' @return list containing "row_count" with the row count value and the correct label.
98		#'
99		#' @note Important is here to not use `df` but `.N_row` in the implementation, because the former
100		#' is already split by columns and will refer to the first column of the data only.
101		#'
102		#' @keywords internal
103		c_label_n <- function(df,
104		labelstr,
105		.N_row) { # nolint
106	270x	label <- paste0(labelstr, " (N=", .N_row, ")")
107	270x	list(row_count = formatters::with_label(c(.N_row, .N_row), label))
108		}
109
110		#' Layout Creating Function to Add Row Total Counts
111		#'
112		#' @description `r lifecycle::badge("stable")`
113		#'
114		#' This works analogously to [rtables::add_colcounts()] but on the rows.
115		#'
116		#' @inheritParams argument_convention
117		#'
118		#' @return The modified layout where the latest row split labels now have the row-wise
119		#' total counts (i.e. without column based subsetting) attached in parentheses. Row
120		#' count values are contained in these row count rows but are not displayed so that
121		#' they are not considered zero rows by default when pruning.
122		#'
123		#' @examples
124		#' basic_table() %>%
125		#' split_cols_by("ARM") %>%
126		#' add_colcounts() %>%
127		#' split_rows_by("RACE", split_fun = drop_split_levels) %>%
128		#' add_rowcounts() %>%
129		#' analyze("AGE", afun = list_wrap_x(summary), format = "xx.xx") %>%
130		#' build_table(DM)
131		#'
132		#' @export
133		add_rowcounts <- function(lyt) {
134	5x	c_lbl_n_fun <- make_afun(
135	5x	c_label_n,
136	5x	.stats = c("row_count"),
137	5x	.formats = c(row_count = function(x, ...) "")
138		)
139	5x	summarize_row_groups(
140	5x	lyt,
141	5x	cfun = c_lbl_n_fun
142		)
143		}
144
145		#' Obtain Column Indices
146		#'
147		#' @description `r lifecycle::badge("stable")`
148		#'
149		#' Helper function to extract column indices from a `VTableTree` for a given
150		#' vector of column names.
151		#'
152		#' @param table_tree (`VTableTree`)\cr table to extract the indices from.
153		#' @param col_names (`character`)\cr vector of column names.
154		#'
155		#' @return the vector of column indices.
156		#'
157		#' @export
158		h_col_indices <- function(table_tree, col_names) {
159	1232x	checkmate::assert_class(table_tree, "VTableNodeInfo")
160	1232x	checkmate::assert_subset(col_names, names(attr(col_info(table_tree), "cextra_args")), empty.ok = FALSE)
161	1232x	match(col_names, names(attr(col_info(table_tree), "cextra_args")))
162		}
163
164		#' Labels or Names of List Elements
165		#'
166		#' Internal helper function for working with nested statistic function results which typically
167		#' don't have labels but names that we can use.
168		#'
169		#' @param x a list
170		#'
171		#' @return a character vector with the labels or names for the list elements
172		#'
173		#' @keywords internal
174		labels_or_names <- function(x) {
175	67x	checkmate::assert_multi_class(x, c("data.frame", "list"))
176	67x	labs <- sapply(x, obj_label)
177	67x	nams <- rlang::names2(x)
178	67x	label_is_null <- sapply(labs, is.null)
179	67x	result <- unlist(ifelse(label_is_null, nams, labs))
180	67x	return(result)
181		}
182
183		#' Convert to `rtable`
184		#'
185		#' @description`r lifecycle::badge("stable")`
186		#'
187		#' This is a new generic function to convert objects to `rtable` tables.
188		#'
189		#' @param x the object which should be converted to an `rtable`.
190		#' @param ... additional arguments for methods.
191		#'
192		#' @return The `rtable` object. Note that the concrete class will depend on the method
193		#' which is used.
194		#'
195		#' @export
196		as.rtable <- function(x, ...) { # nolint
197	3x	UseMethod("as.rtable", x)
198		}
199
200		#' @describeIn as.rtable method for converting `data.frame` that contain numeric columns to `rtable`.
201		#'
202		#' @param format the format which should be used for the columns.
203		#' @method as.rtable data.frame
204		#'
205		#' @examples
206		#' x <- data.frame(
207		#' a = 1:10,
208		#' b = rnorm(10)
209		#' )
210		#' as.rtable(x)
211		#'
212		#' @export
213		as.rtable.data.frame <- function(x, format = "xx.xx", ...) { # nolint
214	3x	checkmate::assert_numeric(unlist(x))
215	2x	do.call(
216	2x	rtable,
217	2x	c(
218	2x	list(
219	2x	header = labels_or_names(x),
220	2x	format = format
221		),
222	2x	Map(
223	2x	function(row, row_name) {
224	20x	do.call(
225	20x	rrow,
226	20x	c(as.list(unname(row)),
227	20x	row.name = row_name
228		)
229		)
230		},
231	2x	row = as.data.frame(t(x)),
232	2x	row_name = rownames(x)
233		)
234		)
235		)
236		}
237
238		#' Split parameters
239		#'
240		#' @description `r lifecycle::badge("stable")`
241		#'
242		#' It divides the data in the vector `param` into the groups defined by `f`
243		#' based on specified `values`.
244		#' It is relevant in `rtables` layers so as to distribute parameters
245		#' `.stats` or' `.formats` into lists with items corresponding to
246		#' specific analysis function.
247		#'
248		#' @param param (`vector`)\cr the parameter to be split.
249		#' @param value (`vector`)\cr the value used to split.
250		#' @param f (`list` of `vectors`)\cr the reference to make the split
251		#'
252		#' @examples
253		#' f <- list(
254		#' surv = c("pt_at_risk", "event_free_rate", "rate_se", "rate_ci"),
255		#' surv_diff = c("rate_diff", "rate_diff_ci", "ztest_pval")
256		#' )
257		#'
258		#' .stats <- c("pt_at_risk", "rate_diff")
259		#' h_split_param(.stats, .stats, f = f)
260		#'
261		#' # $surv
262		#' # [1] "pt_at_risk"
263		#' #
264		#' # $surv_diff
265		#' # [1] "rate_diff"
266		#'
267		#' .formats <- c("pt_at_risk" = "xx", "event_free_rate" = "xxx")
268		#' h_split_param(.formats, names(.formats), f = f)
269		#'
270		#' # $surv
271		#' # pt_at_risk event_free_rate
272		#' # "xx" "xxx"
273		#' #
274		#' # $surv_diff
275		#' # NULL
276		#'
277		#' @export
278		h_split_param <- function(param,
279		value,
280		f) {
281	21x	y <- lapply(f, function(x) param[value %in% x])
282	21x	lapply(y, function(x) if (length(x) == 0) NULL else x)
283		}
284
285		#' Get Selected Statistics Names
286		#'
287		#' Helper function to be used for creating `afun`.
288		#'
289		#' @param .stats (`vector` or `NULL`)\cr input to the layout creating function. Note that `NULL` means
290		#' in this context that all default statistics should be used.
291		#' @param all_stats (`character`)\cr all statistics which can be selected here potentially.
292		#'
293		#' @return Character vector with the selected statistics.
294		#'
295		#' @keywords internal
296		afun_selected_stats <- function(.stats, all_stats) {
297	818x	checkmate::assert_character(.stats, null.ok = TRUE)
298	818x	checkmate::assert_character(all_stats)
299	818x	if (is.null(.stats)) {
300	1x	all_stats
301		} else {
302	817x	intersect(.stats, all_stats)
303		}
304		}
305
306
307		#' Add Variable Labels to Top Left Corner in Table
308		#'
309		#' @description `r lifecycle::badge("stable")`
310		#'
311		#' Helper layout creating function to just append the variable labels of a given variables vector
312		#' from a given dataset in the top left corner. If a variable label is not found then the
313		#' variable name itself is used instead. Multiple variable labels are concatenated with slashes.
314		#'
315		#' @note This is not an optimal implementation of course, since we are using here the data set
316		#' itself during the layout creation. When we have a more mature `rtables` implementation then
317		#' this will also be improved or not necessary anymore.
318		#'
319		#' @inheritParams argument_convention
320		#' @param vars (`character`)\cr variable names of which the labels are to be looked up in `df`.
321		#' @param indent (`integer`)\cr non-negative number of nested indent space, default to 0L which means no indent.
322		#' 1L means two spaces indent, 2L means four spaces indent and so on.
323		#'
324		#' @return The modified layout.
325		#'
326		#' @examples
327		#' lyt <- basic_table() %>%
328		#' split_cols_by("ARM") %>%
329		#' add_colcounts() %>%
330		#' split_rows_by("SEX") %>%
331		#' append_varlabels(DM, "SEX") %>%
332		#' analyze("AGE", afun = mean) %>%
333		#' append_varlabels(DM, "AGE", indent = 1)
334		#' build_table(lyt, DM)
335		#'
336		#' lyt <- basic_table() %>%
337		#' split_cols_by("ARM") %>%
338		#' split_rows_by("SEX") %>%
339		#' analyze("AGE", afun = mean) %>%
340		#' append_varlabels(DM, c("SEX", "AGE"))
341		#' build_table(lyt, DM)
342		#'
343		#' @export
344		append_varlabels <- function(lyt, df, vars, indent = 0L) {
345	3x	if (checkmate::test_flag(indent)) {
346	!	warning("indent argument is now accepting integers. Boolean indent will be converted to integers.")
347	!	indent <- as.integer(indent)
348		}
349
350	3x	checkmate::assert_data_frame(df)
351	3x	checkmate::assert_character(vars)
352	3x	checkmate::assert_count(indent)
353
354	3x	lab <- formatters::var_labels(df[vars], fill = TRUE)
355	3x	lab <- paste(lab, collapse = " / ")
356	3x	space <- paste(rep(" ", indent * 2), collapse = "")
357	3x	lab <- paste0(space, lab)
358
359	3x	append_topleft(lyt, lab)
360		}

1		#' Helper Functions for Tabulating Biomarker Effects on Survival by Subgroup
2		#'
3		#' @description`r lifecycle::badge("stable")`
4		#'
5		#' Helper functions which are documented here separately to not confuse the user
6		#' when reading about the user-facing functions.
7		#'
8		#' @inheritParams survival_biomarkers_subgroups
9		#' @inheritParams argument_convention
10		#' @inheritParams fit_coxreg_multivar
11		#' @name h_survival_biomarkers_subgroups
12		#'
13		#' @examples
14		#' library(dplyr)
15		#' library(forcats)
16		#'
17		#' adtte <- tern_ex_adtte
18		#'
19		#' # Save variable labels before data processing steps.
20		#' adtte_labels <- formatters::var_labels(adtte, fill = FALSE)
21		#'
22		#' adtte_f <- adtte %>%
23		#' filter(PARAMCD == "OS") %>%
24		#' mutate(
25		#' AVALU = as.character(AVALU),
26		#' is_event = CNSR == 0
27		#' )
28		#' labels <- c("AVALU" = adtte_labels[["AVALU"]], "is_event" = "Event Flag")
29		#' formatters::var_labels(adtte_f)[names(labels)] <- labels
30		#'
31		NULL
32
33		#' @describeIn h_survival_biomarkers_subgroups helps with converting the "survival" function variable list
34		#' to the "Cox regression" variable list. The reason is that currently there is an inconsistency between the variable
35		#' names accepted by `extract_survival_subgroups()` and `fit_coxreg_multivar()`.
36		#' @param biomarker (`string`)\cr the name of the biomarker variable.
37		#'
38		#' @examples
39		#' # This is how the variable list is converted internally.
40		#' h_surv_to_coxreg_variables(
41		#' variables = list(
42		#' tte = "AVAL",
43		#' is_event = "EVNT",
44		#' covariates = c("A", "B"),
45		#' strata = "D"
46		#' ),
47		#' biomarker = "AGE"
48		#' )
49		#'
50		#' @export
51		h_surv_to_coxreg_variables <- function(variables, biomarker) {
52	41x	checkmate::assert_list(variables)
53	41x	checkmate::assert_string(variables$tte)
54	41x	checkmate::assert_string(variables$is_event)
55	41x	checkmate::assert_string(biomarker)
56	41x	list(
57	41x	time = variables$tte,
58	41x	event = variables$is_event,
59	41x	arm = biomarker,
60	41x	covariates = variables$covariates,
61	41x	strata = variables$strata
62		)
63		}
64
65		#' @describeIn h_survival_biomarkers_subgroups prepares estimates for number of events, patients and median survival
66		#' times, as well as hazard ratio estimates, confidence intervals and p-values, for multiple biomarkers
67		#' in a given single data set.
68		#' `variables` corresponds to names of variables found in `data`, passed as a named list and requires elements
69		#' `tte`, `is_event`, `biomarkers` (vector of continuous biomarker variables) and optionally `subgroups` and `strat`.
70		#'
71		#' @examples
72		#' # For a single population, estimate separately the effects
73		#' # of two biomarkers.
74		#' df <- h_coxreg_mult_cont_df(
75		#' variables = list(
76		#' tte = "AVAL",
77		#' is_event = "is_event",
78		#' biomarkers = c("BMRKR1", "AGE"),
79		#' covariates = "SEX",
80		#' strata = c("STRATA1", "STRATA2")
81		#' ),
82		#' data = adtte_f
83		#' )
84		#' df
85		#'
86		#' # If the data set is empty, still the corresponding rows with missings are returned.
87		#' h_coxreg_mult_cont_df(
88		#' variables = list(
89		#' tte = "AVAL",
90		#' is_event = "is_event",
91		#' biomarkers = c("BMRKR1", "AGE"),
92		#' covariates = "REGION1",
93		#' strata = c("STRATA1", "STRATA2")
94		#' ),
95		#' data = adtte_f[NULL, ]
96		#' )
97		#'
98		#' @export
99		h_coxreg_mult_cont_df <- function(variables,
100		data,
101		control = control_coxreg()) {
102	21x	assert_df_with_variables(data, variables)
103	21x	checkmate::assert_list(control, names = "named")
104	21x	checkmate::assert_character(variables$biomarkers, min.len = 1, any.missing = FALSE)
105	21x	conf_level <- control[["conf_level"]]
106	21x	pval_label <- paste0(
107		# the regex capitalizes the first letter of the string / senetence.
108	21x	"p-value (", gsub("(^[a-z])", "\\U\\1", trimws(control[["pval_method"]]), perl = TRUE), ")"
109		)
110		# If there is any data, run model, otherwise return empty results.
111	21x	if (nrow(data) > 0) {
112	20x	bm_cols <- match(variables$biomarkers, names(data))
113	20x	l_result <- lapply(variables$biomarkers, function(bm) {
114	40x	coxreg_list <- fit_coxreg_multivar(
115	40x	variables = h_surv_to_coxreg_variables(variables, bm),
116	40x	data = data,
117	40x	control = control
118		)
119	40x	result <- do.call(
120	40x	h_coxreg_multivar_extract,
121	40x	c(list(var = bm), coxreg_list[c("mod", "data", "control")])
122		)
123	40x	data_fit <- as.data.frame(as.matrix(coxreg_list$mod$y))
124	40x	data_fit$status <- as.logical(data_fit$status)
125	40x	median <- s_surv_time(
126	40x	df = data_fit,
127	40x	.var = "time",
128	40x	is_event = "status"
129	40x	)$median
130	40x	data.frame(
131		# Dummy column needed downstream to create a nested header.
132	40x	biomarker = bm,
133	40x	biomarker_label = formatters::var_labels(data[bm], fill = TRUE),
134	40x	n_tot = coxreg_list$mod$n,
135	40x	n_tot_events = coxreg_list$mod$nevent,
136	40x	median = as.numeric(median),
137	40x	result[1L, c("hr", "lcl", "ucl")],
138	40x	conf_level = conf_level,
139	40x	pval = result[1L, "pval"],
140	40x	pval_label = pval_label,
141	40x	stringsAsFactors = FALSE
142		)
143		})
144	20x	do.call(rbind, args = c(l_result, make.row.names = FALSE))
145		} else {
146	1x	data.frame(
147	1x	biomarker = variables$biomarkers,
148	1x	biomarker_label = formatters::var_labels(data[variables$biomarkers], fill = TRUE),
149	1x	n_tot = 0L,
150	1x	n_tot_events = 0L,
151	1x	median = NA,
152	1x	hr = NA,
153	1x	lcl = NA,
154	1x	ucl = NA,
155	1x	conf_level = conf_level,
156	1x	pval = NA,
157	1x	pval_label = pval_label,
158	1x	row.names = seq_along(variables$biomarkers),
159	1x	stringsAsFactors = FALSE
160		)
161		}
162		}
163
164		#' @describeIn h_survival_biomarkers_subgroups prepares a single sub-table given a `df_sub` containing
165		#' the results for a single biomarker.
166		#' @param df (`data.frame`)\cr results for a single biomarker, as part of what is
167		#' returned by [extract_survival_biomarkers()] (it needs a couple of columns which are
168		#' added by that high-level function relative to what is returned by [h_coxreg_mult_cont_df()],
169		#' see the example).
170		#'
171		#' @examples
172		#' # Starting from above `df`, zoom in on one biomarker and add required columns.
173		#' df1 <- df[1, ]
174		#' df1$subgroup <- "All patients"
175		#' df1$row_type <- "content"
176		#' df1$var <- "ALL"
177		#' df1$var_label <- "All patients"
178		#' h_tab_surv_one_biomarker(
179		#' df1,
180		#' vars = c("n_tot", "n_tot_events", "median", "hr", "ci", "pval"),
181		#' time_unit = "days"
182		#' )
183		#'
184		#' @export
185		h_tab_surv_one_biomarker <- function(df,
186		vars,
187		time_unit) {
188	6x	afuns <- a_survival_subgroups()[vars]
189	6x	colvars <- d_survival_subgroups_colvars(
190	6x	vars,
191	6x	conf_level = df$conf_level[1],
192	6x	method = df$pval_label[1],
193	6x	time_unit = time_unit
194		)
195	6x	h_tab_one_biomarker(
196	6x	df = df,
197	6x	afuns = afuns,
198	6x	colvars = colvars
199		)
200		}